Need to refine dependent drop down combobox code to find worksheet tabs

[Jim885]

I have the below dropdown combobox code that works perfectly.

Private Sub Worksheet_Activate()
Dim ws As Worksheet
Me.ComboBox1.Clear
For Each wh In ThisWorkbook.Worksheets
Me.ComboBox1.AddItem ws.Name
Next ws

End Sub

But now need to split this to two dependent dropdown lists/comboboxes.

The first dropdown combobox list should contain all worksheets that contain the name that appears to the left of a hyphen on the worksheet tab.

The second dropdown/combobox list should contain all the words that are to the right of the hyphen on the worksheets tabs that are from the first dropdown list.

Much the same as;

First Dropdown list
Ford

Second Dropdown List
Mustang
Explorer
Ranger
F-150

 

[dmt32]

Hi,
do want the car make to only appear once in the first combobox?

Dave

 

[Jim885]

Yes.
But I'm using car make and an example.
combobox 1 would only list the words to the left of a hyphen on a sheet tab only once
There will be several worksheets that will contain the same name that is left of the hyphen.

The second combobox will be dependent on the first because there may be other sheets that contain the same words to the right of the hyphen that would be in other categories from the first dropdown box
Thank you.

 

[dmt32]

I suspect someone will have a cleaner solution but give following a try & see if does what you want

Private Sub Worksheet_Activate()
    Dim ws As Worksheet
    Dim s() As String
    Dim i As Integer, a As Integer
    Dim CarModel As Variant, CarMake As Variant
    
    ReDim CarModel(1 To ThisWorkbook.Worksheets.Count - 1)
    ReDim CarMake(1 To UBound(CarModel))
    For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> Me.Name Then
        i = i + 1
        s = Split(ws.Name, "-")
        CarModel(i) = s(UBound(s))
        If IsError(Application.Match(s(LBound(s)), CarMake, 0)) Then a = a + 1: CarMake(a) = s(LBound(s))
    End If
    Erase s
    Next ws
    
    ReDim Preserve CarMake(1 To a)
    
    Me.ComboBox1.List = CarMake
    Me.ComboBox2.List = CarModel

End Sub

Dave

 

[Jim885]

Dave,

Thank you for this. It works. However the code populates both comboboxes at the same time when it runs.
The second combobox needs to be dependent upon the selection of the first. So the code for the second combo box should not run until a selection is made at the first combobox.
Can this be done?

 

[Norie]

I've included code to make the contents of ComboBox2 dependent on the selection in ComboBox1.

Private Sub ComboBox1_Change()

    If dicCars Is Nothing Then
        CreateDic
    End If
    
    If Me.ComboBox1.ListIndex <> -1 Then
        Me.ComboBox2.List = dicCars(Me.ComboBox1.Value)
        Me.ComboBox2.ListIndex = -1
    End If
    
End Sub

Private Sub Worksheet_Activate()

    If dicCars Is Nothing Then
        CreateDic
    End If
    
    Me.ComboBox1.List = dicCars.Keys
    
End Sub

Sub CreateDic()
Dim ws As Worksheet
Dim strMake As String
Dim strModel As String
Dim arrModels As Variant
Dim cnt As Long
Dim Pos As Long

    Set dicCars = CreateObject("Scripting.Dictionary")
    
    For Each ws In ThisWorkbook.Sheets
        Pos = InStr(ws.Name, "-")
        strMake = Left(ws.Name, Pos - 1)
        strModel = Mid(ws.Name, Pos + 1)
        
        If Not dicCars.Exists(strMake) Then
            cnt = 1
            ReDim arrModels(1 To 1)
        Else
            cnt = UBound(dicCars(strMake)) + 1
        End If
        
        ReDim Preserve arrModels(1 To cnt)
        arrModels(cnt) = strModel
        
        dicCars(strMake) = arrModels
    Next ws
    
End Sub

 

[dmt32]

Dave,

Thank you for this. It works. However the code populates both comboboxes at the same time when it runs.
The second combobox needs to be dependent upon the selection of the first. So the code for the second combo box should not run until a selection is made at the first combobox.
Can this be done?

It can but I only read this updated to your requirement after I posted code.
See if @Norie solution helps you

Dave

 

[Jim885]

Thanks Dave. I appreciate what you did.


Norie,

Thank you for your help. I'm experiencing two issues.

The first was that the code stopped where I marked below stating "Run-time error 424: Object required" . So I added the line above it to declare dicCars as an Object

Private Sub Worksheet_Activate()
Dim dicCars As Object   '  Added this line
    If dicCars Is Nothing Then  ' <----- code stopped here until I added the line above
        CreateDic
    End If
    Me.ComboBox1.List = dicCars.Keys
End Sub

But after doing that, the code stopped where I marked below stating " Run-time error: Object variable or With block variable not set"

Private Sub Worksheet_Activate()
Dim dicCars As Object
    If dicCars Is Nothing Then
        CreateDic
    End If
    Me.ComboBox1.List = dicCars.Keys  ' <---  code stopped here
End Sub

What could be the issue?

 

[dmt32]

Thanks Dave. I appreciate what you did.

No worries but always worth fully explaining what you want to achieve my solution would have been the following

Place ALL following codes in a STANDARD module

Enum xlCarMakeModel
    xlCarMake
    xlCarModel
End Enum

Sub GetMakeModel(ByVal sh As Object, ByVal Action As xlCarMakeModel)
    Dim ws As Worksheet
    Dim s() As String
    Dim i As Integer, a As Integer
    Dim CarMakeModel As Variant, CarMake As Variant
   
   
    ReDim CarMakeModel(1 To ThisWorkbook.Worksheets.Count - 1)
    CarMake = sh.ComboBox1.Text
    If Len(CarMake) = 0 Then sh.ComboBox2.Clear: Exit Sub
   
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> sh.Name Then
           
            s = Split(ws.Name, "-")
            If Action = xlCarModel Then
                If s(LBound(s)) = CarMake Then a = a + 1: CarMakeModel(a) = s(UBound(s))
            Else
                If IsError(Application.Match(s(LBound(s)), CarMakeModel, 0)) Then a = a + 1: CarMakeModel(a) = s(LBound(s))
            End If
        End If
        Erase s
        Next ws
       
        ReDim Preserve CarMakeModel(1 To a)
       
        If Action = xlCarModel Then
            sh.ComboBox2.list = BubbleSortArray(CarMakeModel)
        Else
            sh.ComboBox1.list = BubbleSortArray(CarMakeModel)
        End If
End Sub


Function BubbleSortArray(ByVal SortArray As Variant) As Variant
    Dim i As Long, j As Long
    Dim Temp As String

    For i = LBound(SortArray) To UBound(SortArray) - 1
        For j = i + 1 To UBound(SortArray)
            If SortArray(i) > SortArray(j) Then
                Temp = SortArray(j)
                SortArray(j) = SortArray(i)
                SortArray(i) = Temp
            End If
        Next j
    Next i
    BubbleSortArray = SortArray
End Function

As an after thought, I have included a bubble sort code to sort the array for combobox lists

Place following codes in your worksheets CODE PAGE

Private Sub ComboBox1_Change()
    GetMakeModel Me, xlCarModel
End Sub

Private Sub Worksheet_Activate()
    GetMakeModel Me, xlCarMake
End Sub

see if this helps you

Dave

 

[Jim885]

Dave,
Thank you very much for this. It's amazing and works perfectly.
Sorry for changing my post to be more specific while you were working on the code.


Norie,
Again thank you for all you did. I'm sure it's just a little tweak that I can investigate later. I put all the code you provided in the sheet page. Maybe rate of it should be in a module?

All the code was amazing.