For loop with multiple listboxes - excel

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

Related

Two Dependent Combo Boxes

**Edit:** Managed to find the solution to it thanks to fellow user #Tin Bum
I'm trying to make 2 Combo Box where the the first one (Cmb1) will show only unique values from Column 1 and then (Cmb2) will show a list of values from Column 2 that are related to Column 1.
Populating the Cmb1 has been successful however the problem lies with populating Cmb2.
Column 1 Column 2
1 a
1 b
1 c
2 d
2 e
The problem lies with populating Cmb2
Private Sub UserForm_Activate()
Dim wslk As Worksheet
Set wslk = Worksheets("w1")
With wslk
t1 = .Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).row
On Error Resume Next
For y = 2 To t1
Set c = .Cells(y, 2)
Set t1rng = .Range(.Cells(2, 2), .Cells(y, 2))
x = Application.WorksheetFunction.CountIf(t1rng, c)
If x = 1 Then Cmb1.AddItem c
Next y
On Error GoTo 0
End With
End Sub
Private Sub Cmb1_Change()
Dim wslk As Worksheet
Set wslk = Worksheets("w1")
Private Sub Cmb1_Change()
Dim wslk As Worksheet
Set wslk = Worksheets("w1")
Cmb2.ListIndex = -1
If Cmb1.ListIndex > -1 Then
'Currently I am stuck over here
Cmb2.List =
**Solution:**
Dim i As Integer
Cmb2.Clear
For i = 2 To wslk.Range("B" & Application.Rows.Count).End(xlUp).row
If wslk.Range("B" & i).Value = Cmb1.Value Then
Cmb2.AddItem wslk.Range("C" & i)
End If
End If
End Sub
This the bones of a solution for the Exit Event Code.
It should be Ok for hundreds of rows but may be slow for thousands of rows, also you still have to workout the 2 ranges - I've arbitrarily assigned them to fixed ranges.
On the plus side it should be simple to follow
Dim Rng1 As Range, Rng2 As Range
Dim xCel As Range, List2 As String
Rng1 = Range("A10:A20") ' whatever Range covers your Col1 Data
Rng2 = Range("B10:B20") ' whatever Range covers your Col2 Data
List2 = ""
For Each xCel In Rng2.Cells
If xCel.Offset(0, -1).Value = Combobox1.Value Then
' Add this Value to a String using VbCrLf as a Separator
List2 = IIf(List2 = "", "", List2 & vbCrLf) & CStr(xCel.Value)
End If
Next xCel
' Split the String into an Array of Values for ComboBox2
ComboBox2.List = Split(List2, vbCrLf)
It also relies on NOT HAVING CHR(13) & CHR(10) (VbCrLF) in your data
You could use a Dictionary to get your unique values and also populate this on your Initialize Sub. Making this a Public variable in the scope of the Userform will allow you to then use it later on the Change event as well to get your list values
Option Explicit
Private Uniques As Object
Private Sub UserForm_Initialize()
Dim c As Range, InputRng As Range
Dim tmp As Variant
Dim k As String
Set Uniques = CreateObject("Scripting.Dictionary")
With Worksheets("w1")
Set InputRng = .Range(.Cells(2, 2), .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 2))
For Each c In InputRng
k = c.Value2
If Uniques.exists(k) Then
tmp = Uniques(k)
ReDim Preserve tmp(LBound(tmp) To UBound(tmp) + 1)
tmp(UBound(tmp)) = c.Offset(0, 1).Value2
Uniques(k) = tmp
Else
ReDim tmp(0)
tmp(0) = c.Offset(0, 1).Value2
Uniques.Add Key:=k, Item:=tmp
End If
Next c
Cmb1.List = Uniques.keys
End With
End Sub
Private Sub Cmb1_Change()
Cmb2.ListIndex = -1
If Cmb1.ListIndex > -1 Then
Cmb2.List = Uniques(Cmb1.Value)
End If
End Sub
Private Sub Cmb1_Change()
Dim wslk As Worksheet
Set wslk = Worksheets("w1")
Dim i As Integer
Cmb2.Clear
For i = 2 To wslk.Range("B" & Application.Rows.Count).End(xlUp).row
If wslk.Range("B" & i).Value = Cmb1.Value Then
Cmb2.AddItem wslk.Range("C" & i)
End If

Autofill listbox from textbox text VBA

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() ?

Copy ONLY text from one range and paste ONLY the first three text on another sheet

I have up to 6 cells with potential data coming from 6 different places. I am trying to get only the first three cells with data transferred to another sheet
Private Sub Transfer_Data()
Sheets("sheet1").Range("A1:A6").SpecialCells(xlCellTypeConstants, 23).copy
Sheets("sheet2").Range("A1:A3").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End Sub
This is what i have i know i am missing allot
This is how I would do it:
Sub Transfer_Data()
Dim i As Long, j As Long
j = 1
For i = 1 To 6
If Sheets("Sheet1").Cells(i, 1).Value <> "" Then
Sheets("Sheet2").Cells(j, 1).Value = Sheets("Sheet1").Cells(i, 1).Value
j = j + 1
End If
If j > 3 Then Exit For
Next i
End Sub
EDITED:
Sub Transfer_Data()
Dim i As Long, j As Long
j = 3
For i = 1 To 6
If Sheets("Sheet1").Cells(i, 1).Value <> "" Then
Sheets("Sheet2").Cells(j, 1).Value = Sheets("Sheet1").Cells(i, 1).Value
j = j - 1
End If
If j = 0 Then Exit For
Next i
End Sub
Untested, there may be another, more elegant way of doing this:
Private Sub TransferData()
Dim cellCount as long
Dim cell as range
Dim rangeToCopy as range
For each cell in Sheets("sheet1").Range("A1:A6").SpecialCells(xlCellTypeConstants) ' 23 is unnecessary, as you get all XlSpecialCellsValue constants by default
' See https://learn.microsoft.com/en-us/office/vba/api/excel.range.specialcells
cellCount = cellCount + cell.cells.count
If not (rangeToCopy is nothing) then
Set rangeToCopy = application.union(rangeToCopy, cell)
Else
Set rangeToCopy = cell
End if
If cellCount = 3 then exit for
Next cell
If not (rangeToCopy is nothing) then
rangeToCopy.copy
Sheets("sheet2").Range("A1").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End if
End Sub
I know this already answered, but how about a crazy one-liner?
Sub TransferData()
ThisWorkbook.Sheets("Sheet2").Range("A1:A3").Value2 = WorksheetFunction.Transpose(Split(Replace$(Join(WorksheetFunction.Transpose(ThisWorkbook.Sheets("Sheet1").Range("A1:A6").Value2), ","), ",,", ","), ","))
End Sub

Dynamically adding column values based on combo box selection

I need your help. It seems what I have written in code does not accomplish what I am trying to do here.
The objective would be to have 2 userform combo boxes one for the (floor) values which are manually added once [3,4,5] and the other combo boxes (offices) in which values are dynamically added based on the selection made in the floor selection box.
Let's say for example that if I chose the value [3] in my floor combo box that the office combo box would contain the following values:
A-01
A-02
A-03
A-04
A-05
A-06
A-07
A-08
I thought this code would work but it doesn't:
'Cells(row, col)
Private Sub floor_Change()
lRow = Sheets("Office Spaces").UsedRange.Rows.Count
With Sheets("Office Spaces")
For i = 2 To lRow
If .Cells(i, 1).Value = UserForm1.floor.Value Then
UserForm1.office.AddItem .Cells(i, 2).Value
End If
Next i
End With
End Sub
Here's what the data looks in my excel sheet:
'Cells(row, col)
Private Sub floor56_Change()
UserForm1.office.Clear
Dim sh
Dim rw
Set sh = Sheets("Office Spaces")
For Each rw In sh.Rows
If sh.Cells(rw.row, 1).Text = UserForm1.floor.Value Then
UserForm1.office.AddItem (sh.Cells(rw.row, 2).Value)
End If
Next rw
End Sub
or
Private Sub floor_Change()
If UserForm1.floor.Value <> "" Then
UserForm1.office.Clear
Dim ws
Set ws = ThisWorkbook.Worksheets("Office Spaces")
Dim rng
Set rng = ws.Range("A:A")
For Each cell In rng
If cell.Text = UserForm1.floor.Value Then
UserForm1.office.AddItem (cell.Offset(0, 1).Value)
End If
Next cell
End If
End Sub

Moving through sequential array items

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:

Resources