combobox from unique values

[roninn75]

Hi
i have a sheet called Ranges where i store 4 related columns of data on. on a second sheet called Summary I have 4 dependant comboboxes.
Combobox1 list values from column A on the Ranges sheet

the following code runs in the Worksheet_Activate event

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng As Range


Set ws1 = Sheets("Ranges")
Set ws2 = Sheets("Summary")


'lets first add the district values
For Each rng In ws1.Range("DISTRICT")
With Me.BxDistrict
    .AddItem rng.Value
End With
Next rng

i want to now populate combobox2 with unique values from the next related column
so i set the related range to go look in:

With ws1
        Set rng = .Range(.Range("I2"), .Range("I100").End(xlUp))
End With

and here is where things start going weird:

Dim CL as range
Dim ClAddress As String
Dim coll As New Collection
        With Me.BxStn
        .Clear
        Set Cl = rng.Find(What:=Me.BxDistrict.Value, LookIn:=xlValues, LookAt:=xlWhole)
        If Not Cl Is Nothing Then
            ClAddress = Cl.Address
            Do
                On Error Resume Next
                coll.Add Item:=Cl.Offset(0, 1).Value, Key:=CStr(Cl.Offset(0, 1).Value)
                On Error GoTo 0
                Set Cl = rng.FindNext(After:=Cl)
            Loop While Not Cl Is Nothing And Cl.Address <> ClAddress
        End If
        For Each itm In coll
            Me.BxStn.AddItem itm
        Next itm
    End With

'lets add the unique platoon names
With ws1
        Set rng = .Range(.Range("J2"), .Range("J100").End(xlUp))
    End With
    With Me.BxPlt
        .Clear
        Set Cl = rng.Find(What:=Me.BxStn.Value, LookIn:=xlValues, LookAt:=xlWhole)
        If Not Cl Is Nothing Then
            ClAddress = Cl.Address
            Do
                On Error Resume Next
                coll.Add Item:=Cl.Offset(0, 1).Value, Key:=CStr(Cl.Offset(0, 1).Value)
                On Error GoTo 0
                Set Cl = rng.FindNext(After:=Cl)
            Loop While Not Cl Is Nothing And Cl.Address <> ClAddress
        End If
        For Each itm In coll
            Me.BxPlt.AddItem itm
        Next itm
    End With

'lets add the unique staff names list
    With ws1
        Set rng = .Range(.Range("K2"), .Range("K100").End(xlUp))
    End With
    With Me.BxName
        .Clear
        Set Cl = rng.Find(What:=Me.BxPlt.Value, LookIn:=xlValues, LookAt:=xlWhole)
        If Not Cl Is Nothing Then
            ClAddress = Cl.Address
            Do
                On Error Resume Next
                coll.Add Item:=Cl.Offset(0, 1).Value, Key:=CStr(Cl.Offset(0, 1).Value)
                On Error GoTo 0
                Set Cl = rng.FindNext(After:=Cl)
            Loop While Not Cl Is Nothing And Cl.Address <> ClAddress
        End If
        For Each itm In coll
            Me.BxName.AddItem itm
        Next itm
    End With

comboboxes 3 and 4 are not pulling the unique values from the next columns through, instead it just repeats the values from the 2nd combobox.
Your assistance is appreciated.

 

[RickXL]

Thanks for helping out, Mick.

Much appreciated.


Regards,

 

[MickG]

You're very welcome
Glad to help!!

 

[teuteux13]

Hi MickG,

Thanks a lot for your support but i need to make it running without double click and all combobox are loaded from an userform and not excel sheet.
My database is stored in Sheet1 then the userform go through it to read the information.
From my current code all the first step are working only my las step i can't display one value.

If you can help again thank you and sorry for the push back.

Regards
TITI

 

[MickG]

Try this in you Userform Code Module:-

Option Explicit
Dim Dic As Object
Private Sub UserForm_Initialize()
Dim Dn As Range
Dim Rng As Range
 With Sheets("Sheet1")
   Set Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
 End With
 Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
   For Each Dn In Rng
        If Not Dic.exists(Dn.Value) Then
           Set Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
        End If
        
        If Not Dic(Dn.Value).exists(Dn.Offset(, 1).Value) Then
           Dic(Dn.Value).Add (Dn.Offset(, 1).Value), Dn.Offset(, 2).Value
        End If
    Next Dn
   
  With ComboBox1
     .List = Dic.Keys
     .ListIndex = -1
  End With
End Sub
Private Sub ComboBox1_Change()
Dim K As Variant, p As Variant
ComboBox2.Clear: ComboBox3.Clear
For Each K In Dic.Keys
  If K = ComboBox1.Value Then
    For Each p In Dic(K)
        ComboBox2.AddItem p
   Next p
End If
Next K
End Sub
Private Sub ComboBox2_Change()
Dim K As Variant, p As Variant
ComboBox3.Clear
For Each K In Dic.Keys
  If K = ComboBox1.Value Then
    For Each p In Dic(K)
        If p = Val(ComboBox2.Value) Then ComboBox3.AddItem Dic(K).Item(p)
   Next p
End If
Next K
End Sub

 

[teuteux13]

Dear MickG,

This is working perfectly. You are my Hero!

Thanks a lot for your support, you make my day!!.

Regards

TITI

 

[MickG]

You're welcome

 

[teuteux13]

You're welcome

Dear Mick,

Last time your help me to solve the problem with 2 combobox.

Now i have an other table but i have to manage 4 combobox consecutive instead of 2.

How to do? I tried to modified your code but didn't succeed.

Thank you for your support.

Best regards

Thibault Turc

 

[MickG]

Please show example of data and the expected results from a specific selection.
I assume this is also for a Userform !!!

 

[teuteux13]

yes it is for an userform

what do you think of the code below with only 3 combobox? no worry for the Dn.offset because my data in the table are not following. I got it working!!! but would like your advise if the code can be optimized or let it be like this. thanks!


Option Explicit
Dim Dic As Object
Dim Dn As Range
Dim Rng As Range
Dim Rng1 As Range



With Sheets("Data")
Set Rng = .Range(.Range("R2"), .Range("R" & Rows.Count).End(xlUp))
Set Rng1 = .Range(.Range("E2"), .Range("E" & Rows.Count).End(xlUp))
End With

Set Dic = CreateObject("Scripting.Dictionary")
Dic.CompareMode = 1
For Each Dn In Rng
If Not Dic.exists(Dn.Value) Then
Set Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
End If

If Not Dic(Dn.Value).exists(Dn.Offset(, -13).Value) Then
Dic(Dn.Value).Add (Dn.Offset(, -13).Value), Dn.Offset(, -2).Value
End If
Next Dn

With ComboBox1
.List = Dic.Keys
.ListIndex = -1
End With

For Each Dn In Rng1
If Not Dic.exists(Dn.Value) Then
Set Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
End If

If Not Dic(Dn.Value).exists(Dn.Offset(, -4).Value) Then
Dic(Dn.Value).Add (Dn.Offset(, -4).Value), Dn.Offset(, -2).Value
End If
Next Dn

With ComboBox2
.List = Dic.Keys
.ListIndex = -1
End With


End Sub
Private Sub ComboBox1_Change()
Dim K As Variant, p As Variant
ComboBox2.Clear
For Each K In Dic.Keys
If K = ComboBox1.Value Then
For Each p In Dic(K)
ComboBox2.AddItem p
Next p
End If
Next K
End Sub
Private Sub ComboBox2_Change()
Dim K As Variant, p As Variant
ComboBox4.Clear
For Each K In Dic.Keys
If K = ComboBox2.Value Then
For Each p In Dic(K)

ComboBox4.AddItem p

Next p
End If
Next K
End Sub

 

[teuteux13]

sorry just found it is not working when i put the code in the Private Sub userform_initialize().