Populate the listbox based on criteria with unique results

[kayza]

Hi All,
I am trying to populate a listbox with unique values based on the criteria found in other columns. And here's an example of the data I want to solve :

	A	B
1	Item A	up
2	Item B	left
3	Item B	left
4	Item B	left
5	Item C	left

<tbody>
</tbody>

In a userform, I have a ComboBox that contains unique values based on column B (already done)
And when I change the value in ComboBox, the list from the listbox fills up according to the criteria I am calling from ComboBox (here I am stuck with the code).
So when I select "left" from combobox, listbox will fill with value
- Item B, and
- Item C

Any help of VBA code for the second question would be greatly appreciated

thanks

 

[gallen]

Are you using form controls or active x?

 

[kayza]

ComboBox and ListBox i put in a UserForm

 

[gallen]

can you show what code you've got already?

 

[kayza]

Hi Gallen.
As I mentioned above, I can only come up with the code to fill the ComboBox with a unique value. And this is the code

Dim wks As Worksheet
Dim bCell As Range


Set wks = Worksheets("Sheet3")
ComboBox1.Clear


With CreateObject("Scripting.Dictionary")
    For Each bCell In wks.Range("B1", wks.Cells(Rows.Count, "B").End(xlUp))
        If Not .exists(bCell.Value) Then
            .Add bCell.Value, Nothing
        End If
    Next bCell


    ComboBox1.List = .keys
End With

And the rest, I'm still stuck.

 

[gallen]

OK I've gone a slightly different route.

This works using the data you provided assuming data starts in row 1. Paste all this code into your userform. I've not commented everything so let me know if something is confusing

Private Sub ComboBox1_Change()

   If ComboBox1.Text <> "" Then FillList
End Sub


Private Sub UserForm_Initialize()
   FillCombo
End Sub


Sub FillList()
    Dim s As String
    Dim sUsed As String, sAdd As String
    Dim c As Range
    Dim ws As Worksheet
    
    s = ComboBox1.Text
    Set ws = Sheets("sheet3")
    
    ListBox1.Clear
    With ws
        For Each c In .Range(Range("A1"), .Range("A" & Rows.Count).End(xlUp))
            
            If c.Offset(0, 1) = s Then
                If InStr(1, sUsed, c) = 0 Then 'check if string already exists in Listbox
                    ListBox1.AddItem c
                    sUsed = sUsed & "," & c 'add value to used variable so we don't add again
                End If
            End If
        Next c
    End With
End Sub


Sub FillCombo()


Dim rngTemp As Range 'holds unique values
Dim ws As Worksheet
Dim l As Long
    
    Set ws = Sheets("sheet3") 'change as needed
    With ws
        Set rngTemp = .Range("AA1") 'use a column that will never be used. It will be deleted after use
    
        .Range(Range("B1"), .Range("B" & Rows.Count).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rngTemp, Unique:=True
    End With
    
    'add uniques to combo
    With ComboBox1
        Do Until rngTemp.Offset(l) = ""
            ComboBox1.AddItem rngTemp.Offset(l) 'Add item
             rngTemp.Offset(l).Clear 'delete temp cell
            l = l + 1
        Loop
       If .ListCount > 0 Then .ListIndex = 0
    End With
    
    Set rngTemp = Nothing
    Set ws = Nothing
    
End Sub

Note: this may be slow if your rows of data runs into tens of thousands.

 

[kayza]

Thanks Gallen for the quick reply, it working. really great time saver.

 

[gallen]

I had issues with the filling combobox part. Mainly this line:

[COLOR=#333333].Range(Range("B1"), .Range("B" & Rows.Count).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rngTemp, Unique:=True[/COLOR]

If you run in to problems let me know

 

[Anupkb]

Hi Gallen.
As I mentioned above, I can only come up with the code to fill the ComboBox with a unique value. And this is the code

Dim wks As Worksheet
Dim bCell As Range


Set wks = Worksheets("Sheet3")
ComboBox1.Clear


With CreateObject("Scripting.Dictionary")
    For Each bCell In wks.Range("B1", wks.Cells(Rows.Count, "B").End(xlUp))
        If Not .exists(bCell.Value) Then
            .Add bCell.Value, Nothing
        End If
    Next bCell


    ComboBox1.List = .keys
End With

And the rest, I'm still stuck.

I know this is an old thread but I was searching from past 4 days for a similar solution and bumped up on this thread. Thanks a lot for this piece of code because It works great for my data sheet as well, just that I have the combo-box parameter in Column D and listbox value in Column A. Modified the offset to (0,4) to get this sorted. But my data has headers so header values are also getting displayed in listbox and combobox.

Tried adding ComboBox1.value ="" and Listbox1.value ="" to end FillCombo subroutine, but still I get Column A header name displayed for listbox. I want my form to have all field as blanks when it is displayed to user and header names should not be displayed for any of the combobox or listboxs. Can you please help?

Thanks again for your solution. You rock!

 

[gallen]

If you have a header row you need to miss out that row.

So for the FillList - start at row 2. The original started at row 1. (highlighted in red below)

[COLOR=#333333]Sub FillList()
[/COLOR]    Dim s As String
    Dim sUsed As String, sAdd As String
    Dim c As Range
    Dim ws As Worksheet
    
    s = ComboBox1.Text
    Set ws = Sheets("sheet3")
    
    ListBox1.Clear
    With ws
        For Each c In .Range(Range("A[SIZE=4][B][COLOR=#ff0000]2[/COLOR][/B][/SIZE]"), .Range("A" & Rows.Count).End(xlUp))
            
            If c.Offset(0, 1) = s Then
                If InStr(1, sUsed, c) = 0 Then 'check if string already exists in Listbox
                    ListBox1.AddItem c
                    sUsed = sUsed & "," & c 'add value to used variable so we don't add again
                End If
            End If
        Next c
    End With [COLOR=#333333]End Sub[/COLOR]

Then for the FillCombo:

Sub FillCombo()




Dim rngTemp As Range 'holds unique values
Dim ws As Worksheet
Dim l As Long
    
    Set ws = Sheets("sheet3") 'change as needed
    With ws
        Set rngTemp = .Range("AA1") 'use a column that will never be used. It will be deleted after use
    
        .Range(Range("B[SIZE=4][B][COLOR=#ff0000]2[/COLOR][/B][/SIZE]"), .Range("B" & Rows.Count).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rngTemp, Unique:=True
    End With
    
    'add uniques to combo
    With ComboBox1
        Do Until rngTemp.Offset(l) = ""
            ComboBox1.AddItem rngTemp.Offset(l) 'Add item
             rngTemp.Offset(l).Clear 'delete temp cell
            l = l + 1
        Loop
       If .ListCount > 0 Then .ListIndex = 0
    End With
    
    Set rngTemp = Nothing
    Set ws = Nothing
    
End Sub

Without testing I think this sorts your issue.