I want a userform where as text is being typed into textbox1, possible values that match the text from the sheet "Data" populate listbox1 and similarly for textbox2 and listbox2. Currently when I type in textbox1, it's filling listbox2 with values from column A in the sheet that is open, instead of the sheet "Data".
Private Sub TextBox1_Change()
Dim i As Integer, ws As Worksheet
ListBox1.Visible = True
Set ws = Sheets("Data")
For i = 2 To Sheets("Data").Range("D6000").End(xlUp).Row
If UCase(Left(ws.Cells(i, 1), Len(TextBox1.Text))) = UCase(TextBox1.Text) Then
ListBox1.AddItem Cells(i, 1)
End If
Next i
End Sub
Private Sub TextBox2_Change()
Dim i As Integer, ws As Worksheet
ListBox2.Visible = True
Set ws = Sheets("Data")
For i = 2 To Sheets("Data").Range("B6000").End(xlUp).Row
If UCase(Left(ws.Cells(i, 1), Len(TextBox2.Text))) = UCase(TextBox2.Text) Then
ListBox2.AddItem Cells(i, 1)
End If
Next i
End Sub
Edit: What I ended up using:
Private Sub TextBox1_Change()
Dim i As Long
Dim arrList As Variant
Me.ListBox1.Clear
If Sheet7.Range("D" & Sheet7.Rows.Count).End(xlUp).Row > 1 And Trim(Me.TextBox1.Value) <> vbNullString Then
arrList = Sheet7.Range("D1:D" & Sheet7.Range("D" & Sheet7.Rows.Count).End(xlUp).Row).Value2
For i = LBound(arrList) To UBound(arrList)
If InStr(1, arrList(i, 1), Trim(Me.TextBox1.Value), vbTextCompare) Then
Me.ListBox1.AddItem arrList(i, 1)
End If
Next i
End If
If Me.ListBox1.ListCount = 1 Then Me.ListBox1.Selected(0) = True
End Sub
Private Sub TextBox2_Change()
Dim i As Long
Dim arrLists As Variant
Me.ListBox2.Clear
If Sheet7.Range("B" & Sheet7.Rows.Count).End(xlUp).Row > 1 And Trim(Me.TextBox2.Value) <> vbNullString Then
arrLists = Sheet7.Range("B1:B" & Sheet7.Range("B" & Sheet7.Rows.Count).End(xlUp).Row).Value2
For i = LBound(arrLists) To UBound(arrLists)
If InStr(1, arrLists(i, 1), Trim(Me.TextBox2.Value), vbTextCompare) Then
Me.ListBox2.AddItem arrLists(i, 1)
End If
Next i
End If
If Me.ListBox2.ListCount = 1 Then Me.ListBox2.Selected(0) = True
End Sub
Use ws.Cells(i, 1) instead of Cells(i, 1).
Also, should the part concerning ListBox2 be moved to TextBox2_Change() ?
Related
I have created a userform with some comboboxes, based on combobox2 I would like to populate combobox1.
In combobox2 there are 6 items to choose from 17, 19, 21, 23, 25, 25+
Based on the selected item in Combobox1 I would like to populate combobox2 as following:
If ItemA is selected, Combobox1 should be populated from range in Sheet ”supply_to_production” range (T6:T1000)
If ItemB is selected, Combobox1 should be populated from range in Sheet ”supply_to_production” range (V6:V1000)
If ItemC is selected, Combobox1 should be populated from range in Sheet ”supply_to_production” range (X6:X1000)
If ItemD is selected, Combobox1 should be populated from range in Sheet ”supply_to_production” range (Z6:Z1000)
If ItemE is selected, Combobox1 should be populated from range in Sheet ”supply_to_production” range (AB6:AB1000)
If ItemF is selected, Combobox1 should be populated from range in Sheet ”supply_to_production” range (AD
6:AD1000)
I have tried the code bellow, it is not giving me any error but is also does not give me any list in combobox1.
`
Private Sub UserForm_Initialize()
With ComboBox2
.AddItem "17"
.AddItem "19"
.AddItem "21"
.AddItem "23"
.AddItem "25"
.AddItem "25+"
End With
End Sub
Private Sub ComboBox1_Update()
Dim index As Integer
index = ComboBox2.ListIndex
ComboBox1.Clear
Select Case index
Case "17":
ComboBox1.List = [SUPPLY_TO_PRODUCTION!T6:T1000]
Case "19":
ComboBox1.List = [SUPPLY_TO_PRODUCTION!V6:V1000]
Case "21":
ComboBox1.List = [SUPPLY_TO_PRODUCTION!X6:X1000]
Case "23":
ComboBox1.List = [SUPPLY_TO_PRODUCTION!Z6:Z1000]
Case "25":
ComboBox1.List = [SUPPLY_TO_PRODUCTION!AB6:AB1000]
Case "25+":
ComboBox1.List = [SUPPLY_TO_PRODUCTION!AD6:AD1000]
End Select
End Sub
`
Something like this should work for you:
Private Sub UserForm_Initialize()
Me.ComboBox2.List = Array(17, 19, 21, 23, 25, "25+")
End Sub
Private Sub ComboBox2_Change()
'Don't have magic numbers, have an easy way to change hard-coded values
Const lStartRow As Long = 6
Me.ComboBox1.Clear
Dim sColumn As String
Select Case CStr(Me.ComboBox2.Value)
Case "17": sColumn = "T"
Case "19": sColumn = "V"
Case "21": sColumn = "X"
Case "23": sColumn = "Z"
Case "25": sColumn = "AB"
Case "25+": sColumn = "AD"
End Select
If Len(sColumn) = 0 Then Exit Sub 'No valid option selected from ComboBox2
'Dynamically size the data
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("SUPPLY_TO_PRODUCTION")
Dim rData As Range: Set rData = ws.Range(ws.Cells(lStartRow, sColumn), ws.Cells(ws.Rows.Count, sColumn).End(xlUp))
Me.ComboBox1.List = rData.Value
End Sub
It looks like you're compiling, where Option Explicit may have saved you?
Try referencing the full range and using the ComboBox2.Value for your Select, such that:
Private Sub ComboBox1_Change()
Dim columnReference as String
Select Case ComboBox2.Value
Case "17":
columnReference = "T"
Case "19":
columnReference = "V"
Case "21":
columnReference = "X"
Case "23":
columnReference = "Z"
Case "25":
columnReference = "AB"
Case "25+":
columnReference = "AD"
End Select
With Sheets("SUPPLY_TO_PRODUCTION")
ComboBox2.List = .Range(.Cells(6,columnReference),.Cells(1000,columnReference)).Value
End With
End Sub
Edit1: Added name of subroutine... Private Sub ComboBox1_Change(), which should trigger the event. Plus, showing images of a quick example which follows this model:
Option Explicit
Private Sub UserForm_Initialize()
ComboBox1.List = Array("animal", "food")
End Sub
Private Sub combobox1_change()
Dim columnReference As Long
Select Case ComboBox1.Value
Case "animal"
columnReference = 1
Case "food"
columnReference = 2
End Select
With Sheets(1)
ComboBox2.List = .Range(.Cells(2, columnReference), .Cells(4, columnReference)).Value
End With
End Sub
Populate Combo Box Based On Selection in Another Combo Box
UserForm e.g. UserForm1 (careful)
Private Sub UserForm_Initialize()
ComboBox2.List = Array("17", "19", "21", "23", "25", "25+")
End Sub
Private Sub ComboBox2_Change()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("SUPPLY_TO_PRODUCTION")
Dim arg As Range: Set arg = ws.Range("T6:T1000," _
& "V6:V1000,X6:X1000,Z6:Z1000,AB6:AB1000,AD6:AD1000")
Dim aIndex As Long: aIndex = ComboBox2.ListIndex + 1 ' zero-based
Dim Data() As Variant: Data = GetColumnRange(arg.Areas(aIndex))
Dim dict As Object: Set dict = DictColumn(Data)
If dict Is Nothing Then Exit Sub
ComboBox1.List = dict.Keys
End Sub
Standard Module e.g. Module1
Function GetColumnRange( _
ByVal rg As Range, _
Optional ByVal ColumnNumber As Long = 1) _
As Variant
If rg Is Nothing Then Exit Function
If ColumnNumber < 1 Then Exit Function
If ColumnNumber > rg.Columns.Count Then Exit Function
With rg.Columns(ColumnNumber)
If rg.Rows.Count = 1 Then
Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = .Value
GetColumnRange = Data
Else
GetColumnRange = .Value
End If
End With
End Function
Function DictColumn( _
ByVal Data As Variant, _
Optional ByVal ColumnIndex As Variant) _
As Object
Const ProcName As String = "DictColumn"
On Error GoTo ClearError
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare ' case-insensitive
Dim c As Long
If IsMissing(ColumnIndex) Then
c = LBound(Data, 2) ' use first column Index2
Else
c = CLng(ColumnIndex)
End If
Dim Key As Variant
Dim r As Long
For r = LBound(Data, 1) To UBound(Data, 1)
Key = Data(r, c)
If Not IsError(Key) Then ' exclude error values
If Len(CStr(Key)) > 0 Then ' exclude blanks
dict(Key) = Empty
End If
End If
Next r
If dict.Count = 0 Then Exit Function ' only error values and blanks
Set DictColumn = dict
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
I pulled the code from a Mr. Excel post and tried to repurpose it for multiple listboxes.
I want the data entered to go across multiple rows based on different variables.
That is for it to make a row of the various combinations that are selected under the listbox.
Image link: https://imgur.com/a/cWcDwNx
I'd like the options in Screenshot 1 to return Screenshot 2, but it returns Screenshot 3.
I'd like the options in Screenshot 4 to return Screenshot 5, but it returns Screenshot 6.
Private Sub CommandButton1_Click()
Dim rng As Range
Dim i As Long
Dim A As Long
Set rng = Range("A" & Rows.Count).End(xlUp).Offset(1)
For A = 0 To ListBox2.ListCount - 1
If ListBox2.Selected(A) = True Then
rng.Resize(, 5).Value = Array(TextBox1.Value, TextBox2.Value, TextBox3.Value, ListBox2.List(A))
Set rng = rng.Offset(1)
End If
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then
rng.Resize(, 5).Value = Array(TextBox1.Value, TextBox2.Value, TextBox3.Value, ListBox1.List(i), ListBox2.List(A))
Set rng = rng.Offset(1)
End If
Next i
Next A
End Sub
Private Sub UserForm_Initialize()
With ListBox1
.List = Array("A", "B", "C")
.ListStyle = fmListStyleOption
.MultiSelect = fmMultiSelectMulti
End With
With ListBox2
.List = Array("Kappa", "Keepo")
.ListStyle = fmListStyleOption
.MultiSelect = fmMultiSelectMulti
End With
End Sub
Where am I going wrong, is it the Syntax or the entire approach?
How could do this for multiple listboxes, maybe even 4?
You need nested loops (untested)
Private Sub CommandButton1_Click()
Dim rng As Range, i As Long, j As Long, ar
Set rng = Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 5)
ar = Array(TextBox1.Value,TextBox2.Value,TextBox3.Value,"","")
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then
ar(3) = ListBox1.List(i)
For j = 0 To ListBox2.ListCount - 1
If ListBox2.Selected(j) = True Then
ar(4) = ListBox2.List(j)
rng.Value = ar
Set rng = rng.Offset(1)
End If
Next
End If
Next
End Sub
Basically I am trying to create multiple dependent dynamic Combo Boxes on a UserForm as it pulls the values from a LookupList Worksheet as seen below
LookupList Worksheet
How it should work:
ComboBox1 would list the company
ComboBox2 is dependent on ComboBox1
ComboBox3 is dependent on ComboBox2
Example:
ComboBox1: Company = Mercedes
ComboBox2: Mercedes Model = A Class
ComboBox3: A Class Model = AMG
I have tried the code below but got stuck on ComboBox2
Private Sub UserForm_Initialize()
'dynamically call ComboBox1 when form initialize
With Worksheets("LookupList")
ComboBox1.List = .Range("A2:A" & .Range("a" & .Rows.Count).End(xlUp).Row).Value
End With
End Sub
Private Sub ComboBox1_Change()
Dim index As Integer
'list ComboBox1 and look for dependency
index = ComboBox1.ListIndex
ComboBox2.Clear
ComboBox3.Clear
'call values in ComboBox2
Select Case index
Case Is = 0
'Calls Mercedes Car Model contents dynamically
With Worksheets("LookupList")
ComboBox2.List = .Range("C2:C" & .Range("c" & Rows.Count).End(xlUp).Row).Value
End With
Case Is = 1
'Calls BMW Car Model contents dynamically
With Worksheets("LookupList")
ComboBox2.List = .Range("G2:G" & .Range("g" & Rows.Count).End(xlUp).Row).Value
End With
End Select
End Sub
Private Sub ComboBox2_Change()
Dim index As Integer
Dim verify_data As Long
index = ComboBox2.ListIndex
verify_data = ComboBox2.ListIndex
'Calls values in ComboBox3
Select Case index
If verify_data = 0 Then
'If Mercedes A Class Model is selected from ComboBox2, list A Class model types
Case Is = 0
With Workseets("LookupList")
ComboBox3.List = .Range("D2:D" & .Range("d" & Rows.Count).End(xlUp).Row).Value
End With
End If
End Select
End Sub
(Posted on behalf of the question author).
I managed to resolve my own issue as shown in code below. If anyone has a shorter method, please feel free to share.
Private Sub ComboBox2_Change()
Dim index As Integer
'list ComboBox2 and look for dependency
index = ComboBox2.ListIndex
ComboBox3.Clear
If Me.ComboBox2.Value = "A Class" Then
With Worksheets("LookupLists")
ComboBox3.List = .Range("D2:D" & .Range("d" &
Rows.Count).End(xlUp).Row).Value
End With
End If
If Me.ComboBox2.Value = "B Class" Then
With Worksheets("LookupLists")
ComboBox3.List = .Range("E2:E" & .Range("e" &
Rows.Count).End(xlUp).Row).Value
End With
End If
End Sub
One way to shorten the code is to refactor it with better syntax and assign each lookup list to a named range.
Private Sub ComboBox2_Change()
Dim index As Integer
'list ComboBox2 and look for dependency
index = ComboBox2.ListIndex
ComboBox3.Clear
Dim whichName as String
Select Case index
Case "A Class": whichName = "aClass" 'assumed named range scoped to worksheet
Case "B Class": whichName = "bClass" 'assumed named range scoped to worksheet
End Select
ComboBox3.List = Worksheets("LookupLists").Range(whichName).Value
End Sub
Try
Private Sub UserForm_Initialize()
Dim Ws As Worksheet
Set Ws = Worksheets("LookupList")
With Ws
ComboBox1.List = .Range("A2:A" & .Range("a" & Rows.Count).End(xlUp).Row).Value
End With
End Sub
Private Sub ComboBox1_Change()
Dim Ws As Worksheet
Dim rngT As Range, rngHead As Range
Set Ws = Worksheets("LookupList")
Set rngHead = Ws.Range("a1", "i1")
ComboBox2.Clear
ComboBox3.Clear
Set rngT = rngHead.Find(ComboBox1.Value, LookIn:=xlValues, Lookat:=xlPart)
If Not rngT Is Nothing Then
ComboBox2.List = Ws.Range(rngT.Offset(1, 0), rngT.End(xlDown)).Value
End If
End Sub
Private Sub ComboBox2_Change()
Dim Ws As Worksheet
Dim rngT As Range, rngHead As Range
Set Ws = Worksheets("LookupList")
Set rngHead = Ws.Range("a1", "i1")
ComboBox3.Clear
If ComboBox2.Value <> "" Then
Set rngT = rngHead.Find(ComboBox2.Value, LookIn:=xlValues, Lookat:=xlPart)
If Not rngT Is Nothing Then
ComboBox3.List = Ws.Range(rngT.Offset(1, 0), rngT.End(xlDown)).Value
End If
End If
End Sub
I am facing a problem in getting the sequence of the unique numbers(Serial number) when the userform is closed and opened later on. Firstly, when I fill the data in the userform everything is captured in the excel sheet perfectly with correct sequence; if I close the userform and run the code by filling the userform with new data the unique ID's are again starting from "1" but not according to the excel sheet row number which was previously saved.
Below is the code I tried:
Private Sub cmdSubmit_Click()
Dim WB As Workbook
Dim lr As Long
Set WB = Workbooks.Open("C:\Users\Desktop\Book2.xlsx")
Dim Database As Worksheet
Set Database = WB.Worksheets("Sheet1")
eRow = Database.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
lr = Database.Range("a65536").End(xlUp).Row
With Sheets("Sheet1")
If IsEmpty(.Range("A1")) Then
.Range("A1").Value = 0
Else
Database.Cells(lr + 1, 1) = Val(Database.Cells(lr, 1)) + 1
End If
End With
Database.Cells(eRow, 4).Value = cmbls.Text
Database.Cells(eRow, 2).Value = txtProject.Text
Database.Cells(eRow, 3).Value = txtEovia.Text
Database.Cells(eRow, 1).Value = txtUid.Text
Call UserForm_Initialize
WB.SaveAs ("C:\Users\Desktop\Book2.xlsx")
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim maxNumber
If Not Intersect(Target, Range("B:B")) Is Nothing Then
' don't run when more than one row is changed
If Target.Rows.Count > 1 Then Exit Sub
' if column A in the current row has a value, don't run
If Cells(Target.Row, 1) > 0 Then Exit Sub
' get the highest number in column A, then add 1 and write to the
' current row, column A
maxNumber = Application.WorksheetFunction.Max(Range("A:A"))
Target.Offset(0, -1) = maxNumber + 1
End If
End Sub
Private Sub UserForm_Initialize()
With txtUid
.Value = Format(Val(Cells(Rows.Count, 1).End(xlUp)) + 1, "0000")
.Enabled = False
End With
With txtProject
.Value = ""
.SetFocus
End With
End Sub
In this image if you see unique id's are repeating 1 and 2, but I need as 1,2,3,4....
I think this is where the issue is coming from. You need to re-calculate the last row every time the user form is Initialized.
Private Sub UserForm_Initialize()
Dim ws as Worksheet: Set ws = Thisworkbook.Sheets("Database")
With txtUid
.Value = Format(ws.Range("A" & ws.Rows.Count).End(xlUp) + 1, "0000")
.Enabled = False
End With
With txtProject
.Value = ""
.SetFocus
End With
End Sub
It's always risky to use row numbers or [max range value +1] as a sequence number.
Safer to use something like a name scoped to the worksheet, which has a value you can increment. Then the sequence is independent of your data.
E.g.
Function GetNextSequence(sht As Worksheet) As Long
Const SEQ_NAME As String = "SEQ"
Dim nm As Name, rv As Long
On Error Resume Next
Set nm = sht.Names(SEQ_NAME)
On Error GoTo 0
'add the name if it doesn't exist
If nm Is Nothing Then
Set nm = sht.Names.Add(Name:=SEQ_NAME, RefersToR1C1:="=0")
End If
rv = Evaluate(nm.Value) + 1
nm.Value = rv
GetNextSequence = rv
End Function
I have checkboxes in my User form and based on selection Of ID from Checkboxes, I want to activate the sheets for particular user in my workbook. I came across some portions of the following code but it's not working properly.
Option Explicit
Private Sub Add_Click()
Dim ctrl As Control
For Each ctrl In UserForm1.Controls
If TypeName(ctrl) = "CheckBox" Then
TransferValues ctrl
End If
Next
End Sub
Sub TransferValues(cb As MSForms.CheckBox)
Dim ws As Worksheet
Dim emptyRow As Long
If cb.Value = True Then
'Define the worksheet based on the CheckBox.Name property:
Set ws = Sheets(Left(cb.Name, 1))
emptyRow = WorksheetFunction.CountA(ws.Range("F:F")) + 1
With ws
If Trim(Me.ComboBox3.Value) = "" Or Trim(Me.ComboBox6.Value) = "" Then
MsgBox ("Please enter text in all fields")
Exit Sub
End If
If WorksheetFunction.CountIf(ws.Range("F:F"), ComboBox3.Value) = 0 Or WorksheetFunction.CountIf(ws.Range("G:G"), ComboBox6.Value) = 0 Then
Cells(emptyRow, 6).Value = ComboBox3.Value
Cells(emptyRow, 7).Value = ComboBox6.Value
Cells(emptyRow, 8).Value = TextBox1.Value
Else
MsgBox ("Warning:Duplicate Entries found. Please update the existing entries")
End If
End With
End If
End Sub
Found solution by own. Please use the following code for such kind of issues if anyone face.
Private Sub CommandButton1_Click()
Dim ctrl As Control
For Each ctrl In Userform1.Controls
If TypeName(ctrl) = "CheckBox" Then
TransferValues ctrl
End If
Next
End Sub
Sub TransferValues(cb As MSForms.CheckBox)
Dim ws As Worksheet
Dim emptyRow As Long
'Dim ID As String
If cb.Value = True Then
Set ws = Sheets(Left(cb.Caption, 6))
If Trim(Me.ComboBox3.Value) = "" Or Trim(Me.ComboBox6.Value) = "" Then
MsgBox ("Please Enter the text in All Fields")
End If
emptyRow = WorksheetFunction.CountA(ws.Range("F:F")) + 1
With ws
If WorksheetFunction.CountIf(ws.Range("F:F"), ComboBox3.Value) = 0 Or WorksheetFunction.CountIf(ws.Range("G:G"), ComboBox6.Value) = 0 Then
.Cells(emptyRow, 6).Value = ComboBox3.Value
.Cells(emptyRow, 7).Value = ComboBox6.Value
.Cells(emptyRow, 8).Value = TextBox1.Value
Else
MsgBox ("Warning:Duplicate Entries Found. Please edit existing entries")
End If
End With
End If
End Sub