VBA Cascading Listboxes 4 columns unique values only

[pangster]

All,

I'm looking for some help... I've followed this tutorial: the third list

https://vbaf1.com/programming/cascading-dropdowns-useform/

ANd have expanded it to allow for 4 listboxes (from 3) - however the slight issue I'm having is that the third listbox is displaying duplicates and I'm not sure how to amend this to show only unique values applicable to the option selected in the second list box... Can anyone help explain how to expand the attached example above to do what I'm wanting (if it's possible)...

<code>
'1. Populate the Regions when you show the Form
Private Sub UserForm_Initialize()

lRow = 455 ' This is last row of your data sheet

For iCntr = 2 To lRow
If Range("A" & iCntr) <> Range("A" & iCntr - 1) Then 'To avoid duplication
lstRegion.AddItem Range("A" & iCntr)
End If
Next

End Sub

'2. Populate the Countries when you change a Regions
Private Sub lstRegion_Change()
lRow = 455 ' This is last row of your data sheet
lstCountry.Clear
lstProducts.Clear
For iCntr = 2 To lRow
If Range("A" & iCntr) = lstRegion.Value And Range("B" & iCntr) <> Range("B" & iCntr - 1) Then
lstCountry.AddItem Range("B" & iCntr)
End If
Next
End Sub

'3. Populate the Products when you change the country
Private Sub lstCountry_Change()
lRow = 455 ' This is last row of your data sheet
lstProducts.Clear
For iCntr = 2 To lRow

If Range("A" & iCntr) = lstRegion.Value And Range("B" & iCntr) = lstCountry.Value Then
lstProducts.AddItem Range("C" & iCntr)
End If

Next
End Sub


'4. Populate the Products when you change the country
Private Sub lstProducts_Change()
lRow = 455 ' This is last row of your data sheet
lstRegulated.Clear
For iCntr = 2 To lRow

If Range("A" & iCntr) = lstRegion.Value And Range("C" & iCntr) = lstProducts.Value Then
lstRegulated.AddItem Range("D" & iCntr)
End If

Next
End Sub

'5. Exit Button
Private Sub CommandButton1_Click()
Unload Me
End Sub

</code>

 

[pangster]

does anyone have any ideas??...

 

[Fluff]

How about

[COLOR=#ff0000]Dim UfDic As Object[/COLOR]

Private Sub lstRegion_Click()
    Me.lstProducts.Clear
    Me.lstRegulated.Clear
    Me.LstCountry.List = UfDic(Me.LstRegion.Value).keys
End Sub

Private Sub lstCountry_Click()
    Me.lstRegulated.Clear
    Me.lstProducts.List = UfDic(Me.LstRegion.Value)(Me.LstCountry.Value).keys
End Sub

Private Sub lstProducts_Click()
    Me.lstRegulated.List = UfDic(Me.LstRegion.Value)(Me.LstCountry.Value)(Me.lstProducts.Value).keys
End Sub

Private Sub UserForm_Initialize()
    Dim Cl As Range
    
    Set UfDic = CreateObject("Scripting.dictionary")
    For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
        If Not UfDic.exists(Cl.Value) Then UfDic.Add Cl.Value, CreateObject("Scripting.dictionary")
        If Not UfDic(Cl.Value).exists(Cl.Offset(, 1).Value) Then UfDic(Cl.Value).Add Cl.Offset(, 1).Value, CreateObject("Scripting.dictionary")
        If Not UfDic(Cl.Value)(Cl.Offset(, 1).Value).exists(Cl.Offset(, 2).Value) Then UfDic(Cl.Value)(Cl.Offset(, 1).Value).Add Cl.Offset(, 2).Value, CreateObject("Scripting.dictionary")
        If Not UfDic(Cl.Value)(Cl.Offset(, 1).Value)(Cl.Offset(, 2).Value).exists(Cl.Offset(, 3).Value) Then UfDic(Cl.Value)(Cl.Offset(, 1).Value)(Cl.Offset(, 2).Value).Add Cl.Offset(, 3).Value, Nothing
    Next Cl
    Me.LstRegion.List = UfDic.keys
End Sub

The part in red must go at the very top of the module, before any code.

 

[arcrazr]

I have adapted this code for my project, with a key difference being that I am drawing the info out of a table (turnoverdata). The first three columns are the keys and it seems like generating the keys is working properly, however when I select the date I get an error that an object is required when the second sub attempts to populate the second combobox. any help would be appreciated.

Dim UfDic As Object



Private Sub UserForm_activate()
    Set UfDic = CreateObject("Scripting.dictionary")
        Dim Cl As Range
       
       
    For Each Cl In Range("turnoverdata[tbdate]")
        If Not UfDic.exists(Cl.Value) Then UfDic.Add Cl.Value, CreateObject("Scripting.dictionary")
        If Not UfDic(Cl.Value).exists(Cl.Offset(, 1).Value) Then UfDic(Cl.Value).Add Cl.Offset(, 1).Value, CreateObject("Scripting.dictionary")
        If Not UfDic(Cl.Value)(Cl.Offset(, 1).Value).exists(Cl.Offset(, 2).Value) Then UfDic(Cl.Value)(Cl.Offset(, 1).Value).Add Cl.Offset(, 2).Value, CreateObject("Scripting.dictionary")
        'If Not UfDic(Cl.Value)(Cl.Offset(, 1).Value)(Cl.Offset(, 2).Value).exists(Cl.Offset(, 3).Value) Then UfDic(Cl.Value)(Cl.Offset(, 1).Value)(Cl.Offset(, 2).Value).Add Cl.Offset(, 3).Value,
    Next Cl
    Me.CBODateUpdate.List = UfDic.keys
End Sub

Private Sub CBODateupdate_Click()
    Me.CBOShiftUpdate.Clear
    Me.CBOLineupdate.List = UfDic(Me.CBODateUpdate.Value).keys
   
End Sub

Private Sub CBOLineupdate_Click()
    Me.CBOShiftUpdate.List = UfDic(Me.CBODateUpdate.Value)(Me.CBOLineupdate.Value).keys
End Sub

 

[Fluff]

Try

UfDic(CDate(Me.CBODateUpdate.Value)).keys

 

[arcrazr]

Well that worked! I do not understand, though why the result of the first selection had to be expressed as a date if it was exactly returned from the dictionary that was just created.

 

[Fluff]

Comboboxes hold text, not dates or numbers, so the values need to be converted back to what is in the dictionary.