Listbox linked to listbox and with unique value

[Yakuzaa]

Hey all,

i want to use excel for may query.
I have for example tree columns:
A B C
1 bel long 123
2 bel short 234
3 ned long 345
4 ned short 456
5 bel long 567
6 lux bigg 987
...

I use a userform to select my query:

listbox1, listbox2, listbox3

What I want:
Listbox1 show the unique valuse in column A

sub listbox1 ()

    Dim AllCells As Range, Cell As Range
    Dim NoDupes As New Collection
    Dim i As Integer, j As Integer
    Dim Swap1, Swap2, Item
    
    Set AllCells = Range("A1:A105")
    
    On Error Resume Next
    For Each Cell In AllCells
        NoDupes.Add Cell.Value, CStr(Cell.Value)

    Next Cell

    On Error GoTo 0

    With UserForm1
        .Label1.Caption = "Total Items: " & AllCells.Count
        .Label2.Caption = "Unique Items: " & NoDupes.Count
    End With
    
    For i = 1 To NoDupes.Count - 1
        For j = i + 1 To NoDupes.Count
            If NoDupes(i) > NoDupes(j) Then
                Swap1 = NoDupes(i)
                Swap2 = NoDupes(j)
                NoDupes.Add Swap1, before:=j
                NoDupes.Add Swap2, before:=i
                NoDupes.Remove i + 1
                NoDupes.Remove j + 1
            End If
        Next j
    Next i
    
    For Each Item In NoDupes
        UserForm1.ListBox1.AddItem Item
    Next Item

    UserForm1.Show
End Sub

that seems to be fine.

Now listbox2 :
When I select in listbox1 example: "bel"
I want listbox2 to show the unique & sorted values "long" & "short"

Listbox3:
show unique & sorted values that meats the value of listbox 1 & 2
in this example listbox2 = "long" then listbox3 = "123" & "567"

Someone ?

Thanks in advance.

 

[erik.van.geit]

Hi, Yakuzaa,
take a look at this code
what you didn't ask is the commandbutton to put results in sheet "archive"
perhaps it usefull: else you can erase it
this is for 4 comboboxes, can be easily edited to 3 listboxes
Const N = 3
delete this part
"Private Sub ComboBox3_Change()
update_comboboxes (3)
End Sub"

'cascading comboboxes :-)
'sources in corresponding columns
  'box1 = column1 ...
'several comboboxes (see N)
  'to expand:
    'add combobox on userform
    'Const N = number of boxes
    'add Private Sub ComboBox ..N.. _Change()
    
Option Explicit

Const N = 4
Public flag As Boolean
Private r As Range, dic As Object

Private Sub userform_initialize()
Dim x As Variant
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("ComboInfo")
    For Each r In .Range(.Cells(2, 1), .Cells(65536, 1).End(xlUp))
        If Not IsEmpty(r) And Not dic.exists(r.Value) Then
            dic.Add r.Value, Nothing
        End If
    Next
End With
x = dic.keys
Me.ComboBox1.List = x
End Sub

Private Sub ComboBox1_Change()
update_comboboxes (1)
'general syntax
'update_comboboxes (Application.WorksheetFunction.Substitute(ActiveControl.Name, "ComboBox", ""))
End Sub
Private Sub ComboBox2_Change()
update_comboboxes (2)
End Sub
Private Sub ComboBox3_Change()
update_comboboxes (3)
End Sub

Sub update_comboboxes(nr As Integer)
Dim ws As Worksheet
Dim i As Integer
Dim check As Boolean
Dim x As Variant

Set ws = Worksheets("ComboInfo")
    For i = nr + 1 To N
    Controls("ComboBox" & i).Clear
    Next i
Set dic = CreateObject("Scripting.dictionary")
    With ws
        For Each r In .Range(.Cells(2, 1), .Cells(65536, 1).End(xlUp))
            For i = 1 To nr
            check = r.Offset(0, i - 1) = Me.Controls("ComboBox" & i).Value
            If check = False Then Exit For
            Next i
            If check And Not dic.exists(r.Offset(0, nr).Value) Then
                dic.Add r.Offset(, nr).Value, Nothing
            End If
        Next
    End With
    With Me.Controls("ComboBox" & nr + 1)
        x = dic.keys
        .List = x
        If .ListCount = 1 Then .ListIndex = 0
    End With
End Sub

Private Sub CommandButton1_Click()
Dim i As Integer
Dim LR As Long
    With Sheets("Archive")
    LR = .Cells(65536, 1).End(xlUp).Offset(1, 0).Row
        For i = 1 To N
        .Cells(LR, i) = Controls("ComboBox" & i)
        Next i
    End With
End Sub

Private Sub CommandButton2_Click()
Unload Me
End Sub

I can email you a sample if you like
kind regards,
Erik

EDIT: slightly enhanced CommandButton1 code

 

[Andrew Poulsom]

Try:

Private Sub UserForm_Initialize()
    Dim Sh As Worksheet
    Dim Rng As Range
    Dim c As Range
    Dim TheList As New Collection
    Dim i As Long
    Dim j As Long
    Dim Temp As Variant
    Dim Item
    Set Sh = Worksheets("Sheet1")
    Set Rng = Sh.Range("A1:A" & Sh.Range("A65536").End(xlUp).Row)
    ListBox1.Clear
'   Create unique list
    On Error Resume Next
    For Each c In Rng
        TheList.Add c.Value, CStr(c.Value)
    Next c
    On Error GoTo 0
'   Sort the list
    If TheList.Count > 1 Then
        For i = 1 To TheList.Count - 1
            For j = i + 1 To TheList.Count
                If TheList(i) > TheList(j) Then
                    Temp = TheList(j)
                    TheList.Remove (j)
                    TheList.Add Temp, CStr(Temp), i
                End If
            Next j
        Next i
    End If
    For Each Item In TheList
        ListBox1.AddItem Item
    Next Item
End Sub

Private Sub ListBox1_Change()
    Dim Sh As Worksheet
    Dim Rng As Range
    Dim c As Range
    Dim TheList As New Collection
    Dim i As Long
    Dim j As Long
    Dim Temp As Variant
    Dim Item
    Set Sh = Worksheets("Sheet1")
    Set Rng = Sh.Range("A1:A" & Sh.Range("A65536").End(xlUp).Row)
    ListBox2.Clear
'   Create unique list
    On Error Resume Next
    For Each c In Rng
        If c.Value = ListBox1.Value Then
            TheList.Add c.Offset(0, 1).Value, CStr(c.Offset(0, 1).Value)
        End If
    Next c
    On Error GoTo 0
'   Sort the list
    If TheList.Count > 1 Then
        For i = 1 To TheList.Count - 1
            For j = i + 1 To TheList.Count
                If TheList(i) > TheList(j) Then
                    Temp = TheList(j)
                    TheList.Remove (j)
                    TheList.Add Temp, CStr(Temp), i
                End If
            Next j
        Next i
    End If
    For Each Item In TheList
        ListBox2.AddItem Item
    Next Item
End Sub

Private Sub ListBox2_Change()
    Dim Sh As Worksheet
    Dim Rng As Range
    Dim c As Range
    Dim TheList As New Collection
    Dim i As Long
    Dim j As Long
    Dim Temp As Variant
    Dim Item
    Set Sh = Worksheets("Sheet1")
    Set Rng = Sh.Range("A1:A" & Sh.Range("A65536").End(xlUp).Row)
    ListBox3.Clear
'   Create unique list
    On Error Resume Next
    For Each c In Rng
        If c.Value = ListBox1.Value Then
            If c.Offset(0, 1).Value = ListBox2.Value Then
                TheList.Add c.Offset(0, 2).Value, CStr(c.Offset(0, 2).Value)
            End If
        End If
    Next c
    On Error GoTo 0
'   Sort the list
    If TheList.Count > 1 Then
        For i = 1 To TheList.Count - 1
            For j = i + 1 To TheList.Count
                If TheList(i) > TheList(j) Then
                    Temp = TheList(j)
                    TheList.Remove (j)
                    TheList.Add Temp, CStr(Temp), i
                End If
            Next j
        Next i
    End If
    For Each Item In TheList
        ListBox3.AddItem Item
    Next Item
End Sub

 

[Yakuzaa]

thx Andrew that's it.

 

[erik.van.geit]

thanks for PM
sample send !