I have an automatically generated listbox with checkboxes. I now want this listbox to check if certain values appear in a range and select these on the listbox.
How do I do this?
I have the following code set up to generate the listbox with values:
Private Sub UserForm_Initialize()
Dim lbtarget As MSForms.ListBox
Dim rngSource As Range
Dim curColumn As Long
Dim LastRow As Long
curColumn = 1
LastRow = Worksheets("Hidden_Classes").Cells(Rows.Count, curColumn).End(xlUp).Row
'Set reference to the range of data to be filled
Set rngSource = Worksheets("Hidden_Classes").Range("A2:A" & LastRow)
'Fill the listbox
Set lbtarget = Me.lstCheckBoxes
With lbtarget
.ListStyle = fmListStyleOption
.MultiSelect = fmMultiSelectMulti
'Insert the range of data supplied
.List = rngSource.Value
End With
End Sub
The items I need to be selected on the listbox appear on the folowing Range:
Worksheets("Hidden_Classes").Range("P2:P15")
As i mentioned in the comment to the question, you have to loop through the items in a ListBox and the values in the column P.
Dim wsh As Worksheet
Dim SecondLastRow As Integer, i As Integer, j As Integer
Set wsh = Worksheets("Hidden_Classes")
'change your code here to use [wsh] variable instead of [Worksheets("Hidden_Classes")]
'add below lines right after [End With]
SecondLastRow = wsh.Range("P" & wsh.Rows.Count).End(xlUp).Row
For i = 0 To lbtarget.ListCount -1
For j = 2 To SecondLastRow
If wsh.Range("A" & i+2) = wsh.Range("P" & j) Then
lbtarget.Selected(i) = True
Exit For 'value has been found and selected, you can skip second [for] loop
End If
Next j
Next i
Should be easy, try:
For i=2 to LastRow
'Customize your condition for adding them to the listbox or just skip the IF if you want to add them all
If Worksheets("Hidden_Classes").Cells(i,"A") = "Condition" Then
lbtarget.AddItem Worksheets("Hidden_Classes").Cells(i,"A")
End If
Next i
Related
The below code basically looks at a source sheet on workbook open, takes the values from a range and loops through adding each value to a combobox.
What I want to do is include some code to ensure only unique values, i.e. no dupes, are added.
Any ideas how I can get that working?
Thanks!
Private Sub Workbook_Open()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim Home As Worksheet
Dim Datasource As Worksheet
'Define Variables and dropdown object
Dim LastRow As Long
Dim MIDCell As Range
Dim ComboMID As ComboBox
Set Home = ActiveSheet
Set Home = Worksheets("UPDATER")
Set Datasource = wb.Sheets("LaunchCodes")
'asign dropdown object to combobox
Set ComboMID = Home.OLEObjects("ComboBox1").Object
'Empty the combobox currnetly to avoid duplicating content
ComboMID.Clear
'With and For loop to put all values in games launch code column, ignoring any blanks, into combobox
With Datasource
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
For Each MIDCell In .Range("D2:D1000" & LastRow)
If MIDCell.Value <> "" Then
ComboMID.AddItem MIDCell.Value
End If
Next
End With
End Sub
The code below avoids looping through cells in a worksheet because it's slow. Actually, that process can be sped up by reading the list into a variable (as, in fact, my code also does) but using Excel's own RemoveDuplicates method appears more efficient.
Private Sub Workbook_Open()
' 155
Dim Wb As Workbook
Dim ComboMid As ComboBox
Dim TmpClm As Long ' number of temporary column
Dim Arr As Variant ' unique values from column D
Set Wb = ThisWorkbook
With Wb.Worksheets("UPDATER")
Set ComboMid = .OLEObjects("ComboBox1").Object
With .UsedRange
TmpClm = .Column + .Columns.Count
End With
End With
With Wb.Sheets("LaunchCodes")
' create a copy of your data (without header) in an unused column
.Cells(2, "D").CurrentRegion.Copy .Cells(1, TmpClm)
.Cells(1, TmpClm).CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlNo
Arr = .Cells(1, TmpClm).CurrentRegion.Value
.Columns(TmpClm).ClearContents
End With
With ComboMid
.List = Arr
.ListIndex = 0 ' assign first list item to Value
End With
End Sub
You don't need to clear the combo box in the above code because replacing the List property with a new array automatically removes whatever it was before.
Unique to ComboBox
To learn about the combo box study this.
You can replace the code after the line Set ComboMID = Home.OLEObjects("ComboBox1").Object with the following snippet:
Dim rng As Range
With DataSource
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
Set rng = .Range("D2:D" & lastrow)
End With
Dim Unique As Variant
Unique = getUniqueFromRange(rng)
If Not IsEmpty(Unique) Then
ComboMID.List = Unique
End If
which uses the following function:
Function getUniqueFromRange( _
rng As Range) _
As Variant
If rng Is Nothing Then
Exit Function
End If
Dim Data As Variant
If rng.Cells.CountLarge > 1 Then
Data = rng.Value
Else
ReDim Data(1 To 1, 1 To 1)
Data(1, 1) = rng.Value
End If
cCount = UBound(Data, 2)
Dim cValue As Variant
Dim i As Long
Dim j As Long
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For i = 1 To UBound(Data, 1)
For j = 1 To cCount
cValue = Data(i, j)
If Not IsError(cValue) And Not IsEmpty(cValue) Then
.Item(cValue) = Empty
End If
Next j
Next i
If .Count > 0 Then
getUniqueFromRange = .Keys
End If
End With
End Function
After running the Userform_Initialize() event, there would be nothing populated in the listbox as shown below:
There should be 11 columns populating the listbox based on the excel table below:
The code ran:
Private Sub UserForm_Initialize()
Dim Total_rows_FoilProfile As Long
Dim row As Range, i As Long
Total_rows_FoilProfile = TotalRowsCount(ThisWorkbook.Name, "Foil Profile", "tblFoilProfile")
ReDim MyArr(0 To Total_rows_FoilProfile - 1)
For Each row In ThisWorkbook.Worksheets("Foil Profile").ListObjects("tblFoilProfile").Range.SpecialCells(xlCellTypeVisible).Rows
MyArr(i) = row.Value
i = i + 1
Next row
lbxFoilInfoDisplay.List = MyArr
frmFoilPanel.Show
The properties of the listbox:
You can populate each list row and then add the columns to it:
Option Explicit
Private Sub UserForm_Initialize()
Dim tblFoilProfile As ListObject
Set tblFoilProfile = ThisWorkbook.Worksheets("Foil Profile").ListObjects("tblFoilProfile")
Dim i As Long
lbxFoilInfoDisplay.Clear
Dim iListRow As Range
For Each iListRow In tblFoilProfile.DataBodyRange.SpecialCells(xlCellTypeVisible).Rows
With Me.lbxFoilInfoDisplay
.AddItem iListRow.Cells(1, 1).Value 'add first value (column 1)
Dim iCol As Long
For iCol = 2 To iListRow.Columns.Count 'add all other columns to that row
.list(i, iCol) = iListRow.Cells(1, iCol).Value '.Value for unformatted value or .Text to show it in the same format as in the cell
Next iCol
i = i + 1
End With
Next iListRow
End Sub
Note here is a nice guide how to work with list objects.
I am trying to populate a ListBox with entries from multiple ListObjects.
But not all entries should be populated, only those which have a specific value in a column of the ListObject.
Example:
ListObjects consist of 3 columns: [Name], [Size], [Position]
All entries from ListObject1 to ListObject5 should be populated into the ListBox if the value in column [Position] is "Top".
Next question based on that result:
How can I then in a second ListBox display all entries of the depended ListObject where [Position] is not "Top".
In other words, not all entries which are not "Top" from all ListObjects should be displayed in the second LIstBox, only those possible entries from the specific ListObject where the value picked in the first ListBox matches.
My thoughts where maybe strange, but what about creating a whole new table (maybe an Array), which consists of all entries from all ListObjects which will be generated when opening the UserForm and then add a third column to it - [ListObjectNumber] - which consists of the information from which Table this information is coming from, that would help the second ListBox to only display the right entries... but maybe this is too far ahead.
Thank you for your help!
In a spreadsheet laid out as such:
Formatted via the Home tab with "Format as Table"; this creates ListObjects
named automatically as "Table1", "Table2", "Table3", "Table4", "Table5"
Sheet named "listbox" for example
ActiveX command button added to show the user form named frmListbox in this example:
Sub Button2_Click()
frmListbox.Show
End Sub
Private Sub cmdPopulate_Click()
Dim ws As Worksheet
Dim table As ListObject
Dim rng As Range
Dim i As Long, j As Long, criteriaRow As Long, lastCol As Long
Dim myarray() As String
With Me.lbUsed
'Set relevant sheetname (or create loop for worksheets)
Set ws = Sheets("listbox")
criteriaRow = -1
For Each table In ws.ListObjects
'Set relevant range/table
'Remember: top row are headings
Set rng = ws.Range(table)
'Remember: last colum not displayed in listbox (-1) for this example
lastCol = rng.Columns.Count - 1
.Clear
.ColumnHeads = False
.ColumnCount = lastCol
'Remember: leave out row 0; column headings
For i = 1 To rng.Rows.Count
If (rng.Cells(i, 3) = "Top") Then
criteriaRow = criteriaRow + 1
'Columns go in first demension so that rows can resize as needed
ReDim Preserve myarray(lastCol, criteriaRow)
For j = 0 To lastCol
myarray(j, criteriaRow) = rng.Cells(i, j + 1)
Next 'Column in table
End If
Next 'Row in table
Next 'Table (ListObject)
'Place array in natural order to display in listbox
.List = TransposeArray(myarray)
'Set the widths of the column, separated with a semicolon
.ColumnWidths = "100;75"
.TopIndex = 0
End With
End Sub
Public Function TransposeArray(myarray As Variant) As Variant
Dim X As Long
Dim Y As Long
Dim Xupper As Long
Dim Yupper As Long
Dim tempArray As Variant
Xupper = UBound(myarray, 2)
Yupper = UBound(myarray, 1)
ReDim tempArray(Xupper, Yupper)
For X = 0 To Xupper
For Y = 0 To Yupper
tempArray(X, Y) = myarray(Y, X)
Next Y
Next X
TransposeArray = tempArray
End Function
For the 2nd question:
The code sample below shows how when clicking on an item in a list called lstDisorder populates the next list box called lstTreatment with the values from named ranges on the spreadsheet.
Private Sub lstDisorder_Click()
Dim x As Integer
x = lstDisorder.ListIndex
Select Case x
Case Is = 0
lstTreatment.RowSource = "Depression"
Case Is = 1
lstTreatment.RowSource = "Anxiety"
Case Is = 2
lstTreatment.RowSource = "OCD"
Case Is = 3
lstTreatment.RowSource = "Stubstance"
End Select
End Sub
Here is another approach:
Private Sub lstTeam_Click()
Dim colUniqueItems As New Collection
Dim vItem As Variant
Dim rFound As Range
Dim FirstAddress As String
'First listBox
Me.lstItems.Clear
'populate first listBox from range on worksheet
With Worksheets("Team").Range("A2:A" & (Cells(1000, 1).End(xlUp).row))
'Find what was clicked in first listBox
Set rFound = .Find(what:=lstTeam.Value, LookIn:=xlValues, lookat:=xlWhole)
'If something is selected, populate second listBox
If Not rFound Is Nothing Then
'Get the address of selected item in first listBox
FirstAddress = rFound.Address
On Error Resume Next
Do
'Add the value of the cell to the right of the cell selected in first listBox to the collection
colUniqueItems.Add rFound.Offset(, 1).Value, CStr(rFound.Offset(, 1).Value)
'Find the next match in the range of the first listBox
Set rFound = .FindNext(rFound)
'Keep looking through the range until there are no more matches
Loop While rFound.Address <> FirstAddress
On Error GoTo 0
'For each item found and stored in the collection
For Each vItem In colUniqueItems
'Add it to the next listBox
Me.lstItems.AddItem vItem
Next vItem
End If
End With
End Sub
Here's a good resource on listBox which shows how to populate ListBox from an Array and how to Get Selected Items from ListBox1 to ListBox2 and more.
I am working on a sheet that have day to day sales data. I need to summaries the data between a specific date. for this I want to use a user form with 2 combo box (I have never worked with user forms & controls ever before). I added the items into combo box by using below codes -
Private Sub UserForm_Initialize()
ComboBox1.RowSource = "A2:A6724"
ComboBox2.RowSource = "A2:A6724"
End Sub
this worked fine. But here is a problem that it is repeating the same items many time as there are many transactions in same date in the sheet.
To solve this issue I search help in internet & found a procedure, I modify that and used in my code. that's working correctly but it also has a little problem that as I click on a date from drop down list of combo box it changes the date format (i.e. if I select 10/12/2016 it shows 12-oct-2016 but it should be 10-dec-2016)
here is the code I modify actually I don't know what it does but I think is will work for me-
Private Sub UserForm_Initialize()
'ComboBox1.RowSource = "A2:A6724"
'ComboBox2.RowSource = "A2:A6724"
Dim Coll As Collection, cell As Range, LastRow As Long
Dim blnUnsorted As Boolean, i As Integer, temp As Variant
Dim SourceSheet As Worksheet
Set SourceSheet = Worksheets("Sheet1")
LastRow = SourceSheet.Cells(Rows.Count, 1).End(xlUp).Row
On Error Resume Next
Set Coll = New Collection
With ComboBox1
.Clear
For Each cell In SourceSheet.Range("A2:A" & LastRow)
If Len(cell.Value) <> 0 Then
Err.Clear
Coll.Add cell.Text, cell.Text
If Err.Number = 0 Then .AddItem cell.Text
End If
Next cell
End With
Set SourceSheet = Worksheets("Sheet1")
LastRow = SourceSheet.Cells(Rows.Count, 1).End(xlUp).Row
On Error Resume Next
Set Coll = New Collection
With ComboBox2
.Clear
For Each cell In SourceSheet.Range("A2:A" & LastRow)
If Len(cell.Value) <> 0 Then
Err.Clear
Coll.Add cell.Text, cell.Text
If Err.Number = 0 Then .AddItem cell.Text
End If
Next cell
End With
Set Coll = Nothing
Set SourceSheet = Nothing
End Sub
I will be greatly Thankful for any help.
Try following code, that use a dictionary.
Public dU1 As Object, cU1 As Variant, iU1 As Long, lrU As Long
Private Sub UserForm_Initialize()
Dim i As Integer
Set dU1 = CreateObject("Scripting.Dictionary")
lrU = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
cU1 = Worksheets("Sheet1").Range("A2:A" & lrU) 'Starts in second row. First row left for titles
For iU1 = 1 To UBound(cU1, 1)
dU1(cU1(iU1, 1)) = 1
Next iU1
'now dU1 has unique values from column A
For i = 0 To dU1.Count - 1
ComboBox1.AddItem dU1.Keys()(i) 'Load Combobox1 with unique values from Column A
Next
End Sub
Private Sub ComboBox1_Change()
Dim lLastRow As Long
Dim i As Integer
ComboBox2.Clear
For i = 0 To dU1.Count - 1
If CDate(ComboBox1.Value) < CDate(dU1.Keys()(i)) Then
ComboBox2.AddItem dU1.Keys()(i) 'Load Combobox2
End If
Next
End Sub
I have been developing a UserForm that uses a listbox populated by the A column to delete specific rows based on listbox selection. But when I click the "Apply" button it takes a ridiculously long time until it processed and deleted the rows.
The code for the Apply button is the following, there is almost no other code in the UserForm. Just Me.Hide in the Cancel button.
Private Sub CommandApply_Click()
Dim i As Long
Dim n As Long
Dim col As New Collection
Dim itm As Variant
Dim rng As Range
' First, collect the row numbers corresponding to the selected items
' We work from last to first
n = Me.ListBox1.ListCount
For i = n - 1 To 0 Step -1
If Me.ListBox1.Selected(i) Then
Else
col.Add i + 1
End If
Next i
' Then delete the rows
Set rng = Worksheets("Sheet1").Range("A1:A100")
For Each itm In col
rng.Rows(itm).EntireRow.Delete
Next itm
blnCancel = False
Me.Hide
End Sub
I think you'd be better off collecting the non-selected items into a Range in your loop and then just deleting that:
Private Sub CommandApply_Click()
Dim i As Long
Dim n As Long
Dim col As New Collection
Dim itm As Variant
Dim rng As Range
' First, collect the row numbers corresponding to the selected items
' We work from last to first
n = Me.ListBox1.ListCount
For i = n - 1 To 0 Step -1
If Not Me.ListBox1.Selected(i) Then
If rng Is Nothing then
Set rng = Worksheets("Sheet1").Range("A" & i + 1)
Else
Set rng = Union(rng, Worksheets("Sheet1").Range("A" & i + 1))
End If
End If
Next i
' Then delete the rows
If not rng Is Nothing then rng.Entirerow.delete
blnCancel = False
Me.Hide
End Sub