i have below VBA code to update long list(1000) of part userform listbox with constant changes to design.
i need help with below 2 issues i am facing with code,
1)somehow, it is only updating only 1st selected item under multiselect listbox. can you pl help to check what is the issue with it to get all selected items updated by command button?
also, there are number of duplicates that i want to updates as well. however, below code updates only one and not other duplicate. can you pl help to correct code so it can update duplicates as well?
Private Sub cmdaction_Click()
Dim t, t1 As String
Dim vrech As Range, lColumn As Range
Dim sh As Worksheet
Dim i As Long
Dim selItem As String
Set sh = ThisWorkbook.Sheets("part bump")
Set lColumn = sh.Range("P1:AZA1").Find(Val(txtchangenumber.Value), , xlValues, xlWhole)
'Set lcolumn1 = sh.Range("F4:F1000")
If UserForm3.txtchangedescrption.Value = "" Then
MsgBox "Please enter Change Description"
Exit Sub
End If
If UserForm3.txtchangenumber.Value = "" Then
MsgBox "Please enter Change Number"
Exit Sub
End If
If UserForm3.cmbaction.Value = "" Then
MsgBox "Please Select part Action"
Exit Sub
End If
If lColumn Is Nothing Then
MsgBox "Change number not found"
Exit Sub
End If
With UserForm3.lstDatabase
For i = 0 To UserForm3.lstDatabase.ListCount - 1
If UserForm3.lstDatabase.Selected(i) = True Then
Set vrech = sh.Range("H4:H250").Find(.Column(7, i), , xlValues, xlWhole)
If Not vrech Is Nothing Then
Select Case cmbaction.Value
Case "RP"
t = Chr(Asc(Mid(.List(i, 7), 2, 1)) + 1)
t1 = Mid(.List(i, 7), 1, 2) & t & Mid(.List(i, 7), 4, 1)
Intersect(vrech.EntireRow, lColumn.EntireColumn) = t1
MsgBox "Selected parts 'RP' Action completed"
Case "RV"
Intersect(vrech.EntireRow, lColumn.EntireColumn) = .List(i, 7)
MsgBox "Selected parts 'RV' Action completed"
Case "DP"
Intersect(vrech.EntireRow, lColumn.EntireColumn) = "Deleted"
vrech.EntireRow.Font.Strikethrough = True
MsgBox "Selected parts 'DP' Action completed"
End Select
End If
End If
Next i
End With
End Sub
Upon further investigation I found that your handling of the Selected property is correct. I have deleted my advice in this regard and apologize for my hasty comment.
I have also re-examined your code and regret, I can't find a reason why it shouldn't deal with all selected items. without access to your workbook i don't have the ability to test and can't help you further.
Your second complaint is caused by this line of code.
Set vrech = sh.Range("H4:H250").Find(.Column(7, i), , xlValues, xlWhole)
It will find the first instance and no others. If you want the search to be repeated a loop will be required that repeats the search. Look up "VBA Find & FindNext MSDN" and you will find code samples how to construct the loop.
Note that in Dim t, t1 As String only t1 is a string. t is defined as a variant by virtue of not having a specified data type. This doesn't appear to be your intention.
I also noted your unusual use of Application.Intersect. Intersect(vrech.EntireRow, lColumn.EntireColumn) should be the equivalent of the simpler Sh.Cells(vrech.Row, lColumn), and it's recommended to specify the Value property when assigning a value to it.
Related
I've been working on the development of a tool that is supposed to help me manage some projects.
I have a table of data called t_data.
This data table contains every projects. Each project is devided on quarters (Q1 2019, Q2 2019, Q3 2019, etc.). Each quarter is devided on deliverables (not always the same number of deliverables so not the same amount of rows for each quarter).
I have a form in another sheet (name of the sheet: MENU!) that permits to add a new deliverable to a Quarter of a project, and where I put the necessary inputs so that I can find the good raw where I should insert my deliverable. The inputs are the project's name (in MENU!D10) and the quarter concerned by the deliverable (in MENU!D12).
Here is my code :
Sub ajouter_un_livrable()
'
' ajouter_un_livrable Macro
' Ajoute un livrable en fonction de son challenge et de son trimestre.
'
Dim result As Variant
match_formula = "EQUIV(1;(t_data[Associated_challenge] = MENU!$D$10)*(t_data[Associated_quarter] = MENU!$D$12);0)"
result = Evaluate(match_formula)
numero_ligne = CLng(result)
numero_ligne = numero_ligne - 2003
Worksheets("TRT RTI Challenges").Rows(numero_ligne).insert
'Set datasheet = Worksheets("TRT RTI Challenges").ListObjects("t_data")
'With datasheet
'.Cells(numero_ligne, 10).Select
'Selection.ListObject.ListRows.Add (numero_ligne)
'Set myNewDeliverable = .ListRows.Add(numero_ligne)
'End With
'
End Sub
You'll notice I'm french ehe
numero_ligne sounds to return the number 2015 because I have an error 2015... great !
I don't know how to manage the EVALUATE. How can I take its value into a variable ? I've tried a lot of things, consult a lot of forums but nothing's working :'(
Do you have an idea of how I could solve my issue ?
Thanks a lot to the one or those that will help me or at least try. :D
I believe something like this should work for you:
Sub ajouter_un_livrable()
Dim wsInput As Worksheet
Dim rProjects As Range
Dim rQuarters As Range
Dim rFound As Range
Dim vProject As Variant
Dim vQuarter As Variant
Dim sProjectCell As String
Dim sQuarterCell As String
Dim sFirst As String
Dim bMatch As Boolean
sProjectCell = "D10"
sQuarterCell = "D12"
On Error Resume Next
Set wsInput = ActiveWorkbook.Worksheets("MENU")
Set rProjects = Range("t_Data").ListObject.ListColumns("Associated_challenge").DataBodyRange
Set rQuarters = Range("t_Data").ListObject.ListColumns("Associated_quarter").DataBodyRange
On Error GoTo 0
If wsInput Is Nothing Or rProjects Is Nothing Or rQuarters Is Nothing Then
MsgBox "Unable to find a worksheet named 'MENU' or unable to find a table named 't_Data' in this workbook.", , "Error"
Exit Sub
End If
vProject = wsInput.Range(sProjectCell).Value
vQuarter = wsInput.Range(sQuarterCell).Value
If Len(vProject) = 0 Then
wsInput.Select
wsInput.Range(sProjectCell).Select
MsgBox "Input for Project is required.", , "Error"
Exit Sub
ElseIf Len(vQuarter) = 0 Then
wsInput.Select
wsInput.Range(sQuarterCell).Select
MsgBox "Input for Quarter is required.", , "Error"
Exit Sub 'No data
End If
bMatch = False
Set rFound = rProjects.Find(vProject, rProjects.Cells(rProjects.Cells.Count), xlValues, xlWhole, , xlNext, False)
If Not rFound Is Nothing Then
sFirst = rFound.Address
Do
If LCase(rQuarters.Worksheet.Cells(rFound.Row, rQuarters.Column).Value) = LCase(vQuarter) Then
bMatch = True
Exit Do
End If
Set rFound = rProjects.FindNext(rFound)
Loop While rFound.Address <> sFirst
If bMatch Then
rFound.EntireRow.Insert
'Row inserted, proceed with what you want to do with the inserted row here
End If
Else
MsgBox "Unable to find matching row for :" & Chr(10) & "Project: " & vProject & Chr(10) & "Quarter: " & vQuarter, , "Error"
End If
End Sub
I am using Applilcation.InputBox to get a number from the user. Further in the code I am multipying a range of cells with that number.
My problem is that I want to know if the number was written manually or chosen by selecting a cell in the worksheet (that means if the user has written „123“ then „123“ and if he has selected a range then return $A$1).
Code:
Dim output As Variant
Set output = Application.InputBox("Enter Number", "Number for multyplying")
Any advice, please?
I don't think you can do this. Either you set the type to 8, and then you can't enter numbers, or you set it to 1 and then you can't enter references. If you combine it to 9, you still have the problem with Set or no Set.
' Works for ranges
Set Output = Application.InputBox("Enter Number", "Number for multyplying", , , , , , 8)
' Works for literals
Output = Application.InputBox("Enter Number", "Number for multyplying", , , , , , 1)
' Could have worked for both, but it doesn't
Set Output = Application.InputBox("Enter Number", "Number for multyplying", , , , , , 9)
I think the cleanest way to solve this is to implement a UserForm with a RefEdit control.
So, with Application.InputBox I wasn't able to achieve the desired functionality, allthough I still think it's possible somehow... :-)
This is what I came up with (using a UserForm with RefEdit and other tools):
Pay no attention to the picture in the background. I was just trying out stuff... :-) Allthough, I quite like it after all :-)
And this is the code for the commandButton:
(ref_Input being the RefEdit, txb_number the TextBox)
Public gNmr As Variant
Private Sub cmd_OK_Click()
Dim adr As String
If ref_Input.Value <> vbNullString And txb_number.Value <> vbNullString Then
MsgBox "Choose just one option, please.", , "Wrong input"
Exit Sub
Else
If ref_Input.Value = vbNullString And txb_number.Value = vbNullString Then
MsgBox "No input, please try again.", , "Wrong input"
Exit Sub
Else
If txb_number.Value = vbNullString Then
adr = ref_Input.Value
gNmr = adr
Else
If ref_Input.Value = vbNullString Then
gNmr = txb_number.Value
End If
End If
End If
End If
Unload Me
End Sub
I'm trying to create a check in/out system at a lab I work at. I'm not to experienced at using VBA. I was able to tinker with some formulas to get it to do what I wanted, but I wasn't fully successful in getting all the steps I wanted done.
So what I'm trying to do is check in samples using a barcode followed by a date in the cell right next to it.
I want this formula to apply to A2000 so I can check in multiple samples. I'm using an input box and I want this input box to be able to detect matched samples and place them in the checked out column C followed by a date in the cell right next to it.
I would appreciate any help you guys can give me.
Here's the code I am currently using.
Private Sub Worksheet_Activate()
Dim myValue As Variant
Dim code As Variant
Dim matchedCell As Variant
myValue = InputBox("Please scan a barcode")
Range("A2").Value = myValue
Set NextCell = Cells(Rows.Count, "A").End(xlUp)
If NextCell.Row > 1 Then NextCell = NextCell.Offset(1, 0)
Set matchedCell = Range("a2:a2000").Find(what:=code, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True)
If myValue = True Then Paste ("C2;C2000")
If Not matchedCell Is Nothing Then matchedCell.Offset(-1, 1).Value = Now
End Sub
To add data safety, I would differentiate the Check-In and the Check-Out process.
I'm not sure how you get the Code from the scanner ? Copied to prompt automatically ?
Anyway, below is my solution:
1.Transform your table into an excel table (CTRL+T) and name it "STORE_RECORDS" as below:
2.Create a module and paste following code:
Option Explicit
Sub Check_In()
Dim Code As String: Code = InputBox("Please scan a barcode", "Scan procedure")
If Code = "" Then MsgBox ("No code scanned"): Exit Sub
Dim NbChIn As Integer: NbChIn = Application.CountIf(Range("STORE_RECORDS[CHECK-IN]"), Code)
Dim NbChOut As Integer: NbChOut = Application.CountIf(Range("STORE_RECORDS[CHECK-OUT]"), Code)
If NbChIn > NbChOut And NbChIn > 0 Then
MsgBox ("This item is already Checked-In" & Chr(10) & "Please check it out and retry"): Exit Sub
Else
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = Code
Cells(Rows.Count, 1).End(xlUp).Offset(0, 1) = Now
End If
End Sub
Sub Check_Out()
Dim Code As String: Code = InputBox("Please scan a barcode", "Scan procedure")
If Code = "" Then MsgBox ("No code scanned"): Exit Sub
Dim NbChIn As Integer: NbChIn = Application.CountIf(Range("STORE_RECORDS[CHECK-IN]"), Code)
Dim NbChOut As Integer: NbChOut = Application.CountIf(Range("STORE_RECORDS[CHECK-OUT]"), Code)
If NbChIn = NbChOut And NbChIn > 0 Then
MsgBox ("This item is already Checked-Out" & Chr(10) & "Please check it in and retry"): Exit Sub
Else
If Range("STORE_RECORDS[CHECK-IN]").Find(Code, , , xlWhole, , xlPrevious) Is Nothing Then MsgBox ("No match, ask Carlos !"): Exit Sub
Range("STORE_RECORDS[CHECK-IN]").Find(Code, , ,xlWhole , , xlPrevious).Offset(0, 2) = Code
Range("STORE_RECORDS[CHECK-IN]").Find(Code, , ,xlWhole , , xlPrevious).Offset(0, 3) = Now
End If
End Sub
3.Link Check-In and Check-Out buttons to respective procedures and you should be good to go.
I am working on a project with an Excel "database" to keep track of production of items. There have been cases of people scanning an item more than once, which causes problems when it's time to send to the client.
I have an alert popup, to prevent people from scanning an item more than once unless dealing with a rework. If the item is present in the "database", there is a MsgBox with vbYesNo buttons. If people click "Yes", it's a rework. If people click "No", it's an error and they exit the sub.
I need a way to handle the rework and have it change the values of the cells in the same row as the original item.
Here's the code I have so far.
Private Sub gbatchd_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) 'Check DB for duplicate value
Set depo = dbgrids.Sheets("Deposition")
Set found = depo.Columns("A").Find(what:=valuetofind, LookIn:=xlValues, lookat:=xlWhole)
valuetofind = gbatchd.Text
FR = depo.Range("A" & Rows.Count).End(xlUp).Row
If KeyCode = 13 Then
For i = 1 To FR
If gbatch.Cells(i, 1).Value = valuetofind Then
MsgBox "This batch has already been deposited!" & vbCrLf & "Rework?", vbYesNo, "Rework?"
If answer = vbNo Then
Exit Sub
Else
depo.Cells(found.Row, 5).Value = "Rework"
End If
End If
Next
End If
End Sub
Setting aside any criticism of the solution's architecture, what your code is missing is the assignment to the answer variable:
answer = MsgBox("This batch has already been deposited!" & vbCrLf & "Rework?", vbYesNo, "Rework?")
Use Option Explicit and declare your variables with the appropriate types (check out this article).
A cleaned-up version of your code might look something like this:
Option Explicit 'At the very top of your module.
'... Other code ...
Private Sub gbatchd_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) 'Check DB for duplicate value
Dim wsDepo As Excel.Worksheet
Dim rngFound As Excel.Range
Dim sValueToFind As String
Dim answer As VbMsgBoxResult
If KeyCode = KeyCodeConstants.vbKeyReturn Then
'Barcode reader has sent the Enter (Return) key.
'Attempt to find the value.
sValueToFind = Trim(gbatchd.Text)
Set wsDepo = dbgrids.Worksheets("Deposition")
Set rngFound = wsDepo.Columns(1).Find(What:=sValueToFind, LookIn:=xlValues, LookAt:=xlWhole)
If Not rngFound Is Nothing Then
'Value was found. Ask whether it is a rework.
answer = MsgBox("This batch has already been deposited!" & vbCrLf & "Rework?", vbYesNo, "Rework?")
If answer = VbMsgBoxResult.vbYes Then
wsDepo.Cells(rngFound.Row, 5).Value = "Rework"
End If
End If
'Cleanup.
Set rngFound = Nothing
Set wsDepo = Nothing
End If
End Sub
I'm new at VBA coding and working on a match code. The code is working just fine when I run the code in "Data sheet" (the sheet were all my data is and were the match has to be found), but when i'm run the code on the frontpage (Sheet 1 with userforms) the code is debuggen and says "Runtime Error 13". Can anybody tell what the problem is?
And can anybody tell me why my "If isError" doesn't work?
Thanks in advance!
Br
'Find SKU and Test number
Dim icol As Integer
Sheet13.Range("XFD2") = UserForm2.ComboBox1.Value 'Sættes = ComboBox1.value
Sheet13.Range("XFD3") = UserForm2.ComboBox2.Value 'Sættes = ComboBox2.value
icol = [Sheet13.MATCH(XFD2&XFD3,A:A&Q:Q,0)] 'Match af værdien for vores SKU og test nr
With ThisWorkbook.Worksheets("Data sheet")
'If SKU or Test number not found, then messagebox
If IsError("A:A") Then MsgBox "SKU not found": Exit Sub
If IsError("Q:Q") Then MsgBox "Test number not found": Exit Sub
'Add test result/next step and comment
.Cells(icol, 30).Value = Me.ComboBox3.Value
.Cells(icol, 30 + 1).Value = Me.Comments_To_Result.Value
End With
End If
Set objFSO = Nothing
Set openDialog = Nothing
Range("XFD2").Clear
Range("XFD3").Clear
icol should be like this:
icol = Application.match(arg1, arg2, arg3)
See the samples in MSDN:
var = Application.Match(Cells(iRow, 1).Value, Worksheets(iSheet).Columns(1), 0)
Concerning If IsError("A:A") Then MsgBox "SKU not found": Exit Sub, you are doing it wrongly. I assume, that you want to loop through all the cells in the first column and to get whether one of them is an error. You need a loop for this. This is a really simple one, but you should implement it somehow in your code:
Option Explicit
Public Sub TestMe()
Dim rng As Range
For Each rng In Range("A:A")
If IsError(rng) Then Debug.Print rng.Address
Next rng
End Sub