Find function works quite good, but there are few exceptions that I don't understand. I have userform, I use find method to get all information about product/item by its code and showing it after button is pressed in userform. Product codes in my table consists of such codes: 1230, 1231, 1232... 1239. The main problem is that I don't understand why numbers like: 1-9, 123 doesn't trigger the msgbox "Can't find product"?
Private Sub btnSearch_Click()
Dim i As Long
Dim totalRows As Long
Dim itemCode As Range
Set itemCode = ThisWorkbook.Sheets("Data").Range("A:A").Find(Me.txtCode.Value)
totalRows = Worksheets("Data").Range("A:A").CurrentRegion.Rows.Count
'searching by code
If Trim(Me.txtCode.Value) = "" Then
Me.txtCode.SetFocus
MsgBox "Need item code"
Exit Sub
End If
If itemCode Is Nothing Then
MsgBox "Can't find product with such code"
End If
For i = 2 To totalRows
If Trim(Cells(i, 1)) = Trim(Me.txtCode) Then
txtName.Text = Cells(i, 2)
'unit of measurement name
txtUnitName.Text = Cells(i, 3)
txtPrice.Text = Cells(i, 4)
Exit For
End If
Next i
End Sub
If you want an exact match, you should add LookAt:=xlWhole to the find parameters.
Otherwise this should do about the same thing, without using find:
Private Sub btnSearch_Click()
Dim i As Long
Dim totalRows As Long
Dim arrData As Variant
With Worksheets("Data")
totalRows = .Cells(Rows.Count, 1).End(xlUp).Row
arrData = .Range("A1:D" & totalRows)
End With
'searching by code
If Trim(Me.txtCode.Value) = "" Then
Me.txtCode.SetFocus
MsgBox "Need item code"
Exit Sub
End If
For i = 2 To totalRows
If Trim(arrData(i, 1)) = Trim(Me.txtCode) Then
txtName.Text = arrData(i, 2)
'unit of measurement name
txtUnitName.Text = arrData(i, 3)
txtPrice.Text = arrData(i, 4)
Exit For
End If
If i = totalRows Then MsgBox "Can't find product with such code"
Next i
End Sub
Replace:
Set itemCode = ThisWorkbook.Sheets("Data").Range("A:A").Find(Me.txtCode.Value)
With:
Set itemCode = ThisWorkbook.Sheets("Data").Range("A:A").Find(Trim(Me.txtCode.Value), LookIn:=xlValues, LookAt:=xlWhole)
Related
I have a dropdown that before was being populated with values from a second sheet in my workbook using the following code:
Private Sub UserForm_Initialize()
Dim cProd As Range
Dim ws As Worksheet
Dim i As Long
Set ws = ThisWorkbook.Worksheets("DO NOT DELETE")
For Each cProd In ws.Range("ProdList")
With Me.dropProd
.AddItem cProd.Value
End With
Next cProd
Me.dropProd.SetFocus
End Sub
Then, I added the code I found here to add the searchable functionality to it, and it was working just fine.
Then I had to tweak my code to add a second dropdown that would be dependent on the first one that I had previously. To do that, I deleted that DO NOT DELETE worksheet, and created two collections to store the values for the dropdowns.
Now, my first dropdown is being populated in this code:
Sub UpdateAll()
Dim ProdID As String
Dim Prod As String
Dim TF As Boolean
Dim lRow As Long
Dim i, t, s
dropProd.Clear
dropPromo.Clear
Set ws = ThisWorkbook.Worksheets("Table View")
Set cProd = New Collection
lRow = ws.Cells(Rows.Count, 1).End(-4162).Row
For i = 13 To lRow
ProdID = ws.Cells(i, 2).Value
Prod = ws.Cells(i, 3).Value
If ProdID <> "" Then
TF = False
If cProd.Count <> 0 Then
For t = 1 To cProd.Count
If cProd(t) = ProdID & " - " & Prod Then TF = True
Next
End If
If TF = False Then cProd.Add (ProdID & " - " & Prod)
End If
Next
For s = 1 To cProd.Count
dropProd.AddItem (cProd(s))
Next
End Sub
Private Sub UserForm_Initialize()
Me.dropProd.SetFocus
UpdateAll
End Sub
This part is also doing great, the below is where I'm having trouble with:
Private Sub dropProd_Change()
Dim ProdInfo As String
Dim Promo As String
Dim q, p
dropPromo.Clear
lRow = ws.Cells(Rows.Count, 1).End(-4162).Row
If dropProd.Value <> "" Then
ProdInfo = Mid(dropProd.Value, 1, InStr(1, dropProd.Value, " - ") - 1)
End If
'Populates Promo ComboBox
For q = 13 To lRow
Promo = ws.Cells(q, 9).Value
If ws.Cells(q, 2).Value = ProdInfo Then dropPromo.AddItem Promo
Next
End Sub
The above works fine if I just select the value from the dropdown, but it breaks every time I try to search anything, and the problem is in this line ProdInfo = Mid(dropProd.Value, 1, InStr(1, dropProd.Value, " - ") - 1)
I've tried to rewrite it in another way, but it's still throwing me an error. Also, I tried to incorporate the code from the link above to see if it would work, but then I didn't know what to reference on me.dropProd.List = ????. I've tried haing this equals to the Collection I have, and of course it didn't work, and now I'm stuck on how to fix it.
I couldn't reproduce the problem with your code line ProdInfo = Mid(dropProd.Value, 1, InStr(1, dropProd.Value, " - ") - 1), it might be data related. Try this alternative ProdInfo = Trim(Split(dropProd.Value, "-")(0)) and a dictionary rather than a collection.
Option Explicit
Dim ws
Sub UpdateAll()
Dim ProdID As String, Prod As String
Dim lastrow As Long, i As Long
dropProd.Clear
dropPromo.Clear
Dim dictProd As Object, k As String
Set dictProd = CreateObject("Scripting.DIctionary")
Set ws = ThisWorkbook.Worksheets("Table View")
With ws
lastrow = ws.Cells(.Rows.Count, 1).End(xlUp).Row
For i = 13 To lastrow
ProdID = Trim(.Cells(i, 2))
If Len(ProdID) > 0 Then
Prod = Trim(.Cells(i, 3))
k = ProdID & " - " & Prod
If Not dictProd.exists(k) Then
dictProd.Add k, 1
End If
End If
Next
dropProd.List = dictProd.keys
End With
End Sub
Private Sub dropProd_Change()
Dim ProdInfo As String, Promo As String
Dim lastrow As Long, i As Long
dropPromo.Clear
If dropProd.Value <> "" Then
ProdInfo = Trim(Split(dropProd.Value, "-")(0))
'Populates Promo ComboBox
With ws
lastrow = ws.Cells(.Rows.Count, 1).End(xlUp).Row
For i = 13 To lastrow
If .Cells(i, 2).Value = ProdInfo Then
Promo = ws.Cells(i, 9).Value
dropPromo.AddItem Promo
End If
Next
End With
End If
End Sub
Private Sub UserForm_Initialize()
Me.dropProd.SetFocus
UpdateAll
End Sub
I'm making a very easy application to insert names and some other info , and I'm getting a problem in the sub. I don't know what's happening , been a long time since I used vba ....
Private Sub button_Click()
Dim linha As Long
linha = Worksheets("FAMINHO_ESCOLAS").cell(Rows.Count, 1).End(xlUp).Row + 1
Range("A" & linha).Value = boxname.Value
Range("B" & linha).Value = boxinstr.Value
Range("C" & linha).Value = boxescola.Value
Range("D" & linha).Value = boxtel.Value
Range("E" & linha).Value = boxemail.Value
End Sub
I'm getting error 438
I'm trying to return the values , when i press the "buttonright" it changes to the next data , and when i press buttonleft it shows me previous data and so on
Private Sub CommandButton1_Click()
GetFAMINHO_ESCOLASLastRow boxname1.Value, boxinstr1.Value, boxescola1.Value,
boxtel1.Value, boxemail1.Value
End Sub
Function GetFAMINHO_ESCOLASLastRow() As Range
Dim Target As Range
With Worksheets("FAMINHO_ESCOLAS")
Set Target = .Cells(.Rows.Count, 1).End(xlUp)
Set Target = Intersect(Target.EntireRow, Target.CurrentRegion)
End With
Set GetFAMINHO_ESCOLASLastRow = Target
End Function
linha is set to the last row but LR is the variable that is actually used for the last row.
linha = Worksheets("FAMINHO_ESCOLAS").Cell(Rows.Count, 1).End(xlUp).Row + 1
Cell( should be changes to Cells(.
linha = Worksheets("FAMINHO_ESCOLAS").Cells(Rows.Count, 1).End(xlUp).Row + 1
It would be better to qualify Rows.Count to the worksheet.
I prefer to write a separate sub routine to add the values. In this way, I can test the code without having to instantiate a userform.
Alternative Solution
Note: AddRowToFAMINHO_ESCOLAS will accept anywhere from 1 to 69 values.
Private Sub button_Click()
AddRowToFAMINHO_ESCOLAS boxname.Value, boxname.Value, boxinstr.Value, boxescola.Value, boxtel.Value, boxemail.Value
End Sub
Sub AddRowToFAMINHO_ESCOLAS(ParamArray Args() As Variant)
With Worksheets("FAMINHO_ESCOLAS")
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(1, UBound(Args) + 1).Value = Args
End With
End Sub
AddRowToFAMINHO_ESCOLAS Demo
Addendum
This function will return the last row with values in column A.
Function GetFAMINHO_ESCOLASLastRow() As Range
Dim Target As Range
With Worksheets("FAMINHO_ESCOLAS")
Set Target = .Cells(.Rows.Count, 1).End(xlUp)
Set Target = Intersect(Target.EntireRow, Target.CurrentRegion)
End With
Set GetFAMINHO_ESCOLASLastRow = Target
End Function
You can test this function by entering the following code into the Immediate Window:
Application.Goto GetFAMINHO_ESCOLASLastRow
Response to Question Update
I changed things up a bit because the OP wants to write and retrieve the values.
Private Sub buttonleft_Click()
Dim Target As Range
Set Target = GetFAMINHO_ESCOLASLastRow
With Target
boxname.Value = .Cells(1, 1).Value
boxinstr.Value = .Cells(1, 2).Value
boxescola.Value = .Cells(1, 3).Value
boxtel.Value = .Cells(1, 4).Value
boxemail.Value = .Cells(1, 5).Value
End With
End Sub
Private Sub buttonright_Click()
Dim Target As Range
Set Target = GetFAMINHO_ESCOLASNewRow
With Target
.Cells(1, 1).Value = boxname.Value
.Cells(1, 2).Value = boxinstr.Value
.Cells(1, 3).Value = boxescola.Value
.Cells(1, 4).Value = boxtel.Value
.Cells(1, 5).Value = boxemail.Value
End With
End Sub
Function GetFAMINHO_ESCOLASLastRow() As Range
Dim Target As Range
With Worksheets("FAMINHO_ESCOLAS")
Set Target = .Cells(.Rows.Count, 1).End(xlUp)
Set Target = Intersect(Target.EntireRow, Target.CurrentRegion)
End With
Set GetFAMINHO_ESCOLASLastRow = Target
End Function
Function GetFAMINHO_ESCOLASNewRow() As Range
Set GetFAMINHO_ESCOLASNewRow = GetFAMINHO_ESCOLASLastRow.Offset(1)
End Function
I want the values in Column D to change depending upon the value in Column A. Some values do not need to be amended at all if the conditions aren't met
Sub Test()
Application.ScreenUpdating = False
Dim startrow As Integer
Dim row As Integer
Dim c As Range
Dim Lastrow As Long
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
For Each c In Range("D2:D" & Lastrow)
If Cells(row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
I think I have an error in the lines beginning with c.Value = c.Value * .....
I'm new to VBA and just trying to make sense of it
I just provide this variant. It is working with array, so theoretically it is very quick. Probably no need to turn off the screen updating.
Sub test()
Dim lastRow As Long, i As Long
With Sheet1
lastRow = .Cells(Rows.Count, "D").End(xlUp).row
Dim vA As Variant 'Represents A2-A lastrow
vA = .Range("A2").Resize(lastRow - 1).Value
Dim vb As Variant 'Represents D2-D lastrow
vb = .Range("D2").Resize(lastRow - 1).Value
i = 0
Dim v As Variant
For Each v In vA
i = i + 1
If v = "Bol" Then
vb(i, 1) = vb(i, 1) * 1.19
ElseIf v = "Amazon" Then
vb(i, 1) = vb(i, 1) * 1.2
End If
Next v
.Range("D2").Resize(lastRow - 1).Value = vb ' Writing the values to the D column
End With
End Sub
You have to forecast and handle all possible conditions. Use this code please:
Sub Test()
Application.ScreenUpdating = False
Dim row As Integer
Dim Lastrow As Long
'I've assumed that you are working on sheet1
Lastrow = Sheets(1).Cells(Rows.Count, "D").End(xlUp).row
If Lastrow > 1 Then
For row = 2 To Lastrow
If Sheets(1).Cells(row, 1).Value = "Bol" Then
Sheets(1).Cells(row, 4).Value = Sheets(1).Cells(row, 4).Value * 1.19
End If
If Sheets(1).Cells(row, 1).Value = "Amazon" Then
Sheets(1).Cells(row, 4).Value = Sheets(1).Cells(row, 4).Value * 1.2
End If
Next
Else
MsgBox ("There is no data at column D")
End If
Application.ScreenUpdating = True
End Sub
There are quite a few ways to go about what you're trying to do. For what it's worth, this is how I would go about it. You had a few additional variables you didn't need, and your 'row' variable wasn't assigned a value at all.
Sub test2()
Dim lastRow As Long, _
i As Long
Application.ScreenUpdating = False
With Sheet1
lastRow = .Cells(Rows.Count, "D").End(xlUp).row
For i = 2 To lastRow
If .Cells(i, 1).Value = "Bol" Then
.Cells(i, 4).Value = .Cells(i, 4).Value * 1.19
End If
If .Cells(i, 1).Value = "Amazon" Then
.Cells(i, 4).Value = .Cells(i, 4).Value * 1.2
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
I kept is relatively simple, so hopefully you can follow what's going on. If you have a lot of "If" statements, it may be cleaner to use VBAs "Select Case".
Also the text strings as you have them set up are case sensitive. "Bol" does not equal "bol" maybe that doesn't matter, but something to be aware of. If the string you pass it is "amazon" it will not pass the 'If' test.
Another assumption I made was that your data is on Sheet1. You should get in the habit of fully qualifying your ranges, it will make your life a lot easier as your code gets more complicated.
Last bit, I'm assuming the values in column D are all numbers. If there is text in there, you may run in to problems multiplying it.
Good luck!
You can simplify your code, and make it easier to read, by looping trough column A instead of column D and using the If/ElseIf statement to test each cell for either of the two conditions. By setting your range and defining c as a range variable for each cell in the range, you only have to loop through each cell and test for the two conditions. If the cell contains Bol use the Offset property to multiple the current value in column D by 1.19; ElseIf the cell contains Amazon use the Offset property to multiple the current value in column D by 1.2. Comments provide in the code.
Application.ScreenUpdating = False
'use the With statement to define your workbook and sheet, change as needed
'Note: "ThisWorkbook" identifies the workbook which contains this code
With ThisWorkbook.Sheets("Sheet1")
'Define the range you want to loop through, using the column you want to test
Dim rng As Range: Set rng = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
'Define the variable for each cell-range
Dim c As Range
'loop through each "c" in the range and if one of the conditions are met
For Each c In rng
If c = "Bol" Then
'then use the "Offset property" to modify the value in column D
c.Offset(, 3) = c.Offset(, 3).Value * 1.19
ElseIf c = "Amazon" Then
c.Offset(, 3) = c.Offset(, 3).Value * 1.2
End If
Next c
End With
Application.ScreenUpdating = True
In-Place Modification
All the solutions have one common issue: you can use them only once. If you need to change the values after adding new records (rows) you should consider adding another column with the initial values so the code could be written to identify what has already been changed and what not. But that's for another question.
Your Sub Solution
You actually had only one serious mistake in two-three places.
Instead of row in the If statements you should have used c.Row and you could have removed Dim row As Integer:
Sub Test_Almost_Fixed()
Application.ScreenUpdating = False
Dim startrow As Integer
Dim c As Range
Dim Lastrow As Long
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
For Each c In Range("D2:D" & Lastrow)
If Cells(c.Row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(c.Row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
Additionally after getting rid of the extra Application.ScreenUpdating = False and the Dim startrow As Integer and some further cosmetics, you could have had something like this:
Sub Test_Fixed()
Dim c As Range
Dim Lastrow As Long
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
Application.ScreenUpdating = False
For Each c In Range("D2:D" & Lastrow)
If Cells(c.Row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(c.Row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
A More Complex Sub Solution
Use the following for the ActiveSheet in a standard module (e.g. Module1). For a particular sheet you can place it in a sheet module (e.g. Sheet1) or create a button on the sheet.
Tip: When you have such a simple (short, fast) code and especially when you're using a Button to run it (in a 'one-time operation code'), it is good practice to use a MsgBox at the end of the code to actually know that the code has run and to prevent accidentally pressing the Button more than once.
Option Explicit
Sub Test()
Const Proc As String = "Test"
On Error GoTo cleanError
' Define Constants.
Const FirstRow As Long = 2
Const SourceColumn As Variant = 1 ' e.g. 1 or "A"
Const TargetColumn As Variant = 4 ' e.g. 4 or "D"
Dim Criteria As Variant ' Add more values.
Criteria = Array("Bol", "Amazon")
Dim Multiplier As Variant ' Add more values.
Multiplier = Array(1.19, 1.2)
' Check if Criteria and Multiplier Arrays have the same number
' of elements (columns).
Dim ubCM As Long: ubCM = UBound(Criteria)
If UBound(Multiplier) <> ubCM Then Exit Sub
' Write Source and Target Ranges to Source and Target Arrays.
Dim rng As Range
' Define Last Non-Empty Cell.
Set rng = Columns(TargetColumn).Find("*", , xlValues, , , xlPrevious)
' Check if Target Column is empty.
If rng Is Nothing Then Exit Sub
' Check if the row of Last Non-Empty Cell is above FirstRow.
If rng.Row < FirstRow Then Exit Sub
Dim Target As Variant
' Write Target Range to Target Array.
Target = Range(Cells(FirstRow, TargetColumn), rng).Value
Set rng = Nothing
Dim ubST As Long: ubST = UBound(Target)
Dim Source As Variant
' Write Source Range to Source Array.
Source = Cells(FirstRow, SourceColumn).Resize(ubST).Value
' Modify Target Array.
Dim i As Long, j As Long
' Loop through elements (rows) of Source and Target Arrays.
For i = 1 To ubST
' Loop through elements (columns) of Criteria and Multiplier Arrays.
For j = 0 To ubCM
' Check if the value in current element (row) of Source Array
' matches the value of current element (column) in Criteria Array.
If Source(i, 1) = Criteria(j) Then
' Modify value in current element (row) of Target Array
' by multiplying it with the value of current element (column)
' of Multiplier Array.
Target(i, 1) = Target(i, 1) * Multiplier(j)
' Since a match is found, there is no need to loop anymore.
Exit For
End If
Next j
Next i
Erase Source
' Write values of Target Array to Target Range.
Cells(FirstRow, TargetColumn).Resize(ubST).Value = Target
Erase Target
' Inform user.
MsgBox "Data copied.", vbInformation, "Success"
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
End Sub
An Event Solution
To make it automatically change the values in column D for each change of a value in column A you can place the following code into the sheet module (e.g. Sheet1):
Option Explicit
Private Const SOURCE_COLUMN As Variant = 1 ' e.g. 1 or "A"
Private Const TARGET_COLUMN As Variant = 4 ' e.g. 4 or "D"
Private Sub sdfWorksheet_Change(ByVal Target As Range)
Const Proc As String = "Worksheet_Change"
On Error GoTo cleanError
If Intersect(Columns(SOURCE_COLUMN), Target) Is Nothing Then Exit Sub
Const FirstRow As Long = 2
Dim rng As Range
Set rng = Columns(TARGET_COLUMN).Find("*", , xlValues, , , xlPrevious)
If rng Is Nothing Then Exit Sub
If rng.Row < FirstRow Then Exit Sub
Set rng = Cells(FirstRow, SOURCE_COLUMN).Resize(rng.row - FirstRow + 1)
If Intersect(rng, Target) Is Nothing Then Exit Sub
Dim cel As Range
Application.Calculation = xlCalculationManual ' -4135
For Each cel In Target.Cells
TestChange cel
Next cel
CleanExit:
Application.Calculation = xlCalculationAutomatic ' -4105
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
On Error GoTo 0
Resume CleanExit
End Sub
Private Sub TestChange(SourceCell As Range)
Const Proc As String = "TestChange"
On Error GoTo cleanError
Dim Criteria As Variant
Criteria = Array("Bol", "Amazon")
Dim Multiplier As Variant
Multiplier = Array(1.19, 1.2)
Dim ubCM As Long: ubCM = UBound(Criteria)
If UBound(Multiplier) <> ubCM Then Exit Sub
Application.ScreenUpdating = False
Dim TargetCell As Range, j As Long
For j = 0 To ubCM
If SourceCell.Value = Criteria(j) Then
Set TargetCell = Cells(SourceCell.row, TARGET_COLUMN)
TargetCell.Value = TargetCell.Value * Multiplier(j)
Exit For
End If
Next j
CleanExit:
Application.ScreenUpdating = True
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
On Error GoTo 0
Resume CleanExit
End Sub
Let me preface this with saying fairly new to VBA.
But I've created a Userform that is taking in First Name, Last Name and Job Title.
Looking to correlate training to job title.
Code references named ranges (1)Merge_Title and (2)Merge_Training from the Merged_DF.
The error I'm encountering is seen in 'Results' pic below. Looking to simply have name, job, and all relevant training associated to that job (ref. Merge_DF pic).
Any help is much appreciated.
Thanks again!
Merge_DF Pic
Results
''' Submits userform into table
Dim lRow As Long
Dim lJob As Long
Dim ws As Worksheet
Dim ws_Merge As Worksheet
Set ws = Worksheets("DATA")
Set ws_Merge = Worksheets("MERGE_DF")
'find first empty row in table
lRow = ws.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
lJob = Me.CmboJob.ListIndex
'verify data entered
If Trim(Me.TextFirst.Value) = "" Then
Me.TextFirst.SetFocus
MsgBox "You Forgot the First Name"
Exit Sub
End If
If Trim(Me.TextLast.Value) = "" Then
Me.TextLast.SetFocus
MsgBox "You Forgot the Last Name"
Exit Sub
End If
If Trim(Me.CmboJob.Value) = "" Then
Me.CmboJob.SetFocus
MsgBox "You Forgot the Job Title"
Exit Sub
End If
'loops and records data
For Each c In ws_Merge.Range("Merge_Title")
If c = Me.CmboJob.Value Then
With ws
.Cells(lRow, 1).Value = Me.TextLast.Value
.Cells(lRow, 2).Value = Me.TextFirst.Value
.Cells(lRow, 4).Value = Me.CmboJob.Value
For Each i In ws_Merge.Range("Merge_Training")
ws.Cells(lRow, 7).Value = i.Value
lRow = lRow + 1
Next
' lRow = lRow + 1
End With
End If
Next c
Me.TextLast.Value = ""
Me.TextFirst.Value = ""
Me.CmboJob.Value = ""
Me.CmboJob.SetFocus
End Sub
The code below creates an array of unique values from values in Column A. Each selected array element is used to select a range on the sheet. The range is displayed in a userform Listbox.
I would like help with code that would allow the user to scroll through each array ‘MyarUniqVal’ element via two form buttons Right ‘>>’ and Left ‘<<’. Each time a button is pressed a sequential array item will be selected and a new range will populate the Listbox.
Any help would be greatly appreciated.
Thanks,
Please see the code below:
Sub testRange3()
Dim lastrow, i, j As Long
Dim c As Range, rng As Range
Dim MyArUniqVal() As Variant
ReDim MyArUniqVal(0)
'With ActiveSheet
With ThisWorkbook.Worksheets("Temp")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To lastrow
If .Cells(i, 1).Value <> .Cells(i + 1, 1).Value Then
MyArUniqVal(UBound(MyArUniqVal)) = .Cells(i, 1).Value
ReDim Preserve MyArUniqVal(UBound(MyArUniqVal) + 1)
End If
Next
ReDim Preserve MyArUniqVal(UBound(MyArUniqVal) - 1)
End With
For j = LBound(MyArUniqVal) To UBound(MyArUniqVal)
'Prints out each array to Immediate Window
Debug.Print j
'Prints out unique values from Column A stored in array to Immediate Window
Debug.Print MyArUniqVal(j)
Next
With ThisWorkbook.Worksheets("Temp")
'changed to ActiveSheet
'With ActiveSheet
For Each c In .Range("A1:A" & lastrow)
For j = LBound(MyArUniqVal) To UBound(MyArUniqVal)
If UCase(c.Text) = j Then
'If UCase(c.Text) = "B" Then
If rng Is Nothing Then
Set rng = .Range("B" & c.Row).Resize(, 2)
Debug.Print rng
Else
Set rng = Union(rng, .Range("B" & c.Row).Resize(, 2))
Exit For
Debug.Print rng
End If
End If
Next
Next c
End With
If Not rng Is Nothing Then rng.Select
End Sub
See the following code to get you heading the the right direction. I took the approach of adding another listbox that displayed the available prefixes to help the user see what was available and then searching the data column for entries containing the selected prefix.
Hopefully you will be able to adapt the name of the variables and objects to whatever you are currently using. Let me know if anything needs clarification. Best of luck with your project.
My sample form code:
Private Sub cmdBack_Click()
code_frmMain.IncrementValue (0)
End Sub
Private Sub cmdNext_Click()
code_frmMain.IncrementValue (1)
End Sub
Private Sub lstPrefixes_Change()
code_frmMain.DisplayNext
End Sub
Private Sub UserForm_Initialize()
code_frmMain.testRange3
End Sub
My sample program code:
' This subroutine will search column B for the selected value
Sub DisplayNext()
Dim searchTerm As String
Dim lastRow As Long
Dim i As Integer
' clear frmMain.lstResults
frmMain.lstResults.Clear
For i = 0 To frmMain.lstPrefixes.ListCount - 1
If frmMain.lstPrefixes.Selected(i) = True Then
searchTerm = frmMain.lstPrefixes.List(i)
Exit For ' exits once selected item is found
End If
Next i
'Debug.Print searchTerm
With Sheets("Temp")
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
For i = 1 To lastRow
If InStr(Cells(i, 2).Value, searchTerm) Then
frmMain.lstResults.AddItem (Cells(i, 2).Value)
End If
Next i
End Sub
' increments value. input direction: 0 is down and 1 is up
Sub IncrementValue(direction As Integer)
Dim currentIndex As Integer
currentIndex = -1
For i = 0 To frmMain.lstPrefixes.ListCount - 1
If frmMain.lstPrefixes.Selected(i) = True Then
currentIndex = frmMain.lstPrefixes.ListIndex
Exit For ' exits once selected item is found
End If
Next i
' defaults to first item if none selected
If currentIndex = -1 Then
frmMain.lstPrefixes.Selected(0) = True
currentIndex = 0
End If
If direction = 0 Then
' prevents listIndex from being invalid
If currentIndex = 0 Then
frmMain.lstPrefixes.Selected(frmMain.lstPrefixes.ListCount - 1) = True
Else
frmMain.lstPrefixes.Selected(currentIndex - 1) = True
End If
Else
If currentIndex = frmMain.lstPrefixes.ListCount - 1 Then
frmMain.lstPrefixes.Selected(0) = True
Else
frmMain.lstPrefixes.Selected(currentIndex + 1) = True
End If
End If
End Sub
Note that I also added this to the bottom of your testRange3() to use that data that you had already gathered:
For i = 0 To UBound(MyArUniqVal)
frmMain.lstPrefixes.AddItem (MyArUniqVal(i))
Next i
Sample Data:
Running on user form: