combobox from unique values

roninn75 · Aug 29, 2015

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

Code:

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:

Code:

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

and here is where things start going weird:

Code:

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

Code:

'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

Code:

'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.

MickG · Dec 9, 2016

Try this for 4 comboboxes (ie 4 columns of data)
NB:- Data on sheet1
Place code in Useform Module

Code:

Option Explicit
Private [COLOR=navy]Sub[/COLOR] ComboBox1_Change()
ComboBox2.Value = ""
Call cValues(ComboBox1.Value, ComboBox2, 2)
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Private [COLOR=navy]Sub[/COLOR] ComboBox2_Change()
ComboBox3.Value = ""
Call cValues(ComboBox2.Value, ComboBox3, 3)
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Private [COLOR=navy]Sub[/COLOR] ComboBox3_Change()
ComboBox4.Value = ""
Call cValues(ComboBox3.Value, ComboBox4, 4)
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Private [COLOR=navy]Sub[/COLOR] UserForm_Initialize()
[COLOR=navy]Dim[/COLOR] Rng         [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Dn          [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Dic         [COLOR=navy]As[/COLOR] Object
[COLOR=navy]With[/COLOR] Sheets("Sheet1")
[COLOR=navy]Set[/COLOR] Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
 [COLOR=navy]End[/COLOR] With
        [COLOR=navy]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
            Dic.CompareMode = vbTextCompare
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng: Dic(Dn.Value) = Empty: [COLOR=navy]Next[/COLOR]
    Me.ComboBox1.List = Application.Transpose(Dic.keys)
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
[COLOR=navy]Sub[/COLOR] cValues(txt [COLOR=navy]As[/COLOR] [COLOR=navy]String,[/COLOR] Obj [COLOR=navy]As[/COLOR] Object, col [COLOR=navy]As[/COLOR] Integer)
[COLOR=navy]Dim[/COLOR] Dn              [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Rng             [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Dic             [COLOR=navy]As[/COLOR] Object
[COLOR=navy]With[/COLOR] Sheets("Sheet1")
[COLOR=navy]Set[/COLOR] Rng = .Range(.Cells(2, col), .Cells(Rows.Count, col).End(xlUp))
  [COLOR=navy]End[/COLOR] With
  [COLOR=navy]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
[COLOR=navy]If[/COLOR] txt <> "" [COLOR=navy]Then[/COLOR]
   [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
       [COLOR=navy]If[/COLOR] Dn.Offset(, -1).Value = txt [COLOR=navy]Then[/COLOR]
            [COLOR=navy]If[/COLOR] Not Dic.exists(Dn.Value) [COLOR=navy]Then[/COLOR]
                 Dic(Dn.Value) = Empty
            [COLOR=navy]End[/COLOR] If
        [COLOR=navy]End[/COLOR] If
   [COLOR=navy]Next[/COLOR] Dn
Obj.List = Application.Transpose(Dic.keys)
[COLOR=navy]End[/COLOR] If
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

teuteux13 · Dec 15, 2016

Dear Mick,sorry for my late answer. this is working very well after adapting to my current code.You are a master, i always appreciate your support.Cheers!

MickG · Dec 15, 2016

You're welcome

teuteux13 · Mar 7, 2017

Hi Mike,

I found something wrong on the final result with your code and 4 combobox

For exemple if we choose from the table below NM (ComboBox1) then AD (ComboBox2) then M (ComboBox3) the result should be 1030 because the original starting check is from NM and no FM right?
but in fact on the comboBox4 I have 2 result such as 1030 and 3030.

How to modify the code to the last comboBox4 to recognize the original selection and fall on the good result?

[FONT=宋体]ColA[/FONT]	[FONT=宋体]ColB[/FONT]	[FONT=宋体]ColC[/FONT]	[FONT=宋体]ColD[/FONT]
[FONT=宋体]NM[/FONT]	[FONT=宋体]AD[/FONT]	[FONT=宋体]T[/FONT]	[FONT=宋体]1030[/FONT]
[FONT=宋体]NM[/FONT]	[FONT=宋体]AD[/FONT]	[FONT=宋体]M[/FONT]	[FONT=宋体]1030[/FONT]
[FONT=宋体]NM[/FONT]	[FONT=宋体]AD[/FONT]	[FONT=宋体]D[/FONT]	[FONT=宋体]1030[/FONT]
[FONT=宋体]NM[/FONT]	[FONT=宋体]AD[/FONT]	[FONT=宋体]T[/FONT]	[FONT=宋体]3030[/FONT]
[FONT=宋体]NM[/FONT]	[FONT=宋体]AD[/FONT]	[FONT=宋体]B[/FONT]	[FONT=宋体]3030[/FONT]
[FONT=宋体]FM[/FONT]	[FONT=宋体]CA[/FONT]	[FONT=宋体]T[/FONT]	[FONT=宋体]1030[/FONT]
[FONT=宋体]FM[/FONT]	[FONT=宋体]CA[/FONT]	[FONT=宋体]M[/FONT]	[FONT=宋体]3030[/FONT]
[FONT=宋体]FM[/FONT]	[FONT=宋体]CA[/FONT]	[FONT=宋体]D[/FONT]	[FONT=宋体]1030[/FONT]
[FONT=宋体]FM[/FONT]	[FONT=宋体]CA[/FONT]	[FONT=宋体]T[/FONT]	[FONT=宋体]3030[/FONT]
[FONT=宋体]FM[/FONT]	[FONT=宋体]CA[/FONT]	[FONT=宋体]B[/FONT]	[FONT=宋体]3030[/FONT]

MickG · Mar 7, 2017

Try this Userform Module code:-

Rich (BB code):

Option Explicit
Private Sub ComboBox1_Change()
Dim Com As String
Com = ComboBox1.Value
ComboBox2.Value = ""
Call cValues(Com, ComboBox2, 2)
End Sub
Private Sub ComboBox2_Change()
Dim Com As String
Com = ComboBox1.Value & "," & ComboBox2.Value
ComboBox3.Value = ""
Call cValues(Com, ComboBox3, 3)
End Sub
Private Sub ComboBox3_Change()
Dim Com As String
Com = ComboBox1.Value & "," & ComboBox2.Value & "," & ComboBox3.Value
ComboBox4.Value = ""
Call cValues(Com, ComboBox4, 4)
End Sub
Private Sub UserForm_Initialize()
Dim Rng         As Range
Dim Dn          As Range
Dim Dic         As Object
With Sheets("Sheet1")
Set Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
 End With
        Set Dic = CreateObject("scripting.dictionary")
            Dic.CompareMode = vbTextCompare
For Each Dn In Rng: Dic(Dn.Value) = Empty: Next
    Me.ComboBox1.List = Application.Transpose(Dic.keys)
End Sub
Sub cValues(txt As String, Obj As Object, col As Integer)
Dim Dn              As Range
Dim Rng             As Range
Dim Dic             As Object
Dim nStr            As String
With Sheets("Sheet1")
Set Rng = .Range(.Cells(2, col), .Cells(Rows.Count, col).End(xlUp))
  End With
  Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
   For Each Dn In Rng
       If col = 2 Then
       nStr = Dn.Offset(, -1).Value
       Else
       nStr = Join(Application.Transpose(Application.Transpose(Cells(Dn.Row, 1).Resize(, col - 1))), ",")
       End If
        If nStr = txt Then
            If Not Dic.exists(Dn.Value) Then
                 Dic(Dn.Value) = Empty
            End If
        End If
   Next Dn
If Dic.Count > 0 Then
Obj.List = Application.Transpose(Dic.keys)
End If
End Sub

Regards Mick

teuteux13 · Mar 7, 2017

Dear Mick,

you did it! ...It works perfectly.

Thank you so much, you save me an other day of researches and work!

MickG · Mar 7, 2017

You're welcome

teuteux13 · Jun 4, 2024

MickG said:
You're welcome

Hi Mike, back to your last code when i put it in the Sheet1 without userform i can't get combobox 3 and 4 working if the data are from the sheet2 as example.

Can you check what is wrong in the code below?

Private Sub ComboBox1_Change()
Dim Com As String
Com = ComboBox1.Value
ComboBox2.Value = ""
Call cValues(Com, ComboBox2, 2)
End Sub
Private Sub ComboBox2_Change()
Dim Com As String
Com = ComboBox1.Value & "," & ComboBox2.Value
ComboBox3.Value = ""
Call cValues(Com, ComboBox3, 3)
End Sub

Private Sub ComboBox3_Change()
Dim Com As String
Com = ComboBox1.Value & "," & ComboBox2.Value & "," & ComboBox3.Value
ComboBox4.Value = ""
Call cValues(Com, ComboBox4, 4)
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Rng As Range
Dim Dn As Range
Dim Dic As Object
With Sheets("Sheet2")
Set Rng = Worksheets("Sheet2").Range(.Range("A2"), Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp))
End With
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
For Each Dn In Rng: Dic(Dn.Value) = Empty: Next
Me.ComboBox1.List = Application.Transpose(Dic.keys)
End Sub
Sub cValues(txt As String, Obj As Object, col As Integer)
Dim Dn As Range
Dim Rng As Range
Dim Dic As Object
Dim nStr As String
With Worksheets("Sheet2")
Set Rng = .Range(.Cells(2, col), .Cells(Rows.Count, col).End(xlUp))
End With
Set Dic = CreateObject("Scripting.Dictionary")
Dic.CompareMode = 1
For Each Dn In Rng
If col = 2 Then
nStr = Dn.Offset(, -1).Value
Else:
nStr = Join(Application.Transpose(Application.Transpose(Cells(Dn.Row, 1).Resize(, col - 1))), ",")
End If
If nStr = txt Then
If Not Dic.exists(Dn.Value) Then
Dic(Dn.Value) = Empty
End If
End If
Next Dn
If Dic.Count > 0 Then
Obj.List = Application.Transpose(Dic.keys)
End If
End Sub

combobox from unique values

roninn75

New Member

MickG

MrExcel MVP

Excel Facts

teuteux13

New Member

MickG

MrExcel MVP

teuteux13

New Member

MickG

MrExcel MVP

teuteux13

New Member

MickG

MrExcel MVP

teuteux13

New Member

Similar threads

Forum statistics

Share this page

combobox from unique values

New Member

MrExcel MVP

Excel Facts

New Member

MrExcel MVP

New Member

MrExcel MVP

New Member

MrExcel MVP

New Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock