Dependent dropdown list

[ObiwanKenobi24]

Hello,

I have a problem to be able to create this macro, I explain more below.

First, I have 2 sheets. The first one is called Dropdown and this sheet shows 2 columns. Column A is the Country column and column B is the City column. This sheet groups all the cities that a country can have. There are lots of countries and cities so we must assume that the data can be infinite.

Then, I have the second sheet called PCM where I need to put the information. For example, if I write in column D row 2 the state of UK, I want the macro to create a dropdown list in next column same row (E2) with their respective cities. This data validation list must contain the cities that correspond to its country and these are extracted from the Dropdown sheet. For example, for the state of UK the dropdown list created in next column same row should be: Birmingham, Glasgow, Liverpool and Cardiff. I need this to happen every time I write a country (always in column D) that is listed in the Dropdown sheet and in the next column the same row with their respective cities in the form of a dropdown list.

An example:

The code I've been working is this one but no success until now. If someone could help me with this it would be very kind.

Sub DistributeDropdowns()
    Const ProcName As String = "DistributeDropdowns"
    On Error GoTo ClearError

    Const sName As String = "Dropdown"
    Const saCol As Long = 1
    Const svCol As Long = 2
    
    Const dvRows As String = "2:1000"

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion.Columns(saCol)

    Dim nCount As Long: nCount = srg.Rows.Count
    Dim nData As Variant: nData = srg.Value
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim n As Long
    Dim nString As String
    
    For n = 2 To nCount
        nString = nData(n, 1)
        If dict.Exists(nString) Then
            Set dict(nString) = Union(dict(nString), sws.Cells(n, svCol))
        Else
            Set dict(nString) = sws.Cells(n, svCol)
        End If
    Next n
        
    Application.ScreenUpdating = False
    
 Const dwsName As String = "PCM"
    Dim dws As Worksheet: Set dws = wb.Worksheets(dwsName)
    Dim drg As Range
    
    For Each Cell In Range("D2:D1000").Cells
        If dict.Exists(nData(n, 4)) Then
            With dws.Range("D2:D1000").Cells
                nCount = .Columns.Count
                nData = .Value
                Set drg = .EntireColumn.Rows(dvRows)
            End With
            For n = 2 To nCount
                    If dict.Exists(nData(n, 4)) Then
                        With drg.Rows(n).Validation
                            .Delete
                            .Add xlValidateList, xlValidAlertStop, xlEqual, _
                                "='" & sName & "'!" & dict(nData(n, 4)).Address
                            .IgnoreBlank = True
                            .InCellDropdown = True
                            .InputTitle = ""
                            .ErrorTitle = ""
                            .InputMessage = ""
                            .ErrorMessage = ""
                            .ShowInput = True
                            .ShowError = True
                        End With
                    End If
            
            Next n
        End If
    Next
    
    'wb.Save
    
    Application.ScreenUpdating = True
    MsgBox "Dropdowns distributed.", vbInformation

ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Sub

Thanks.

 

[kevin9999]

This would be so much simpler if you had a later version of Excel

Place the following code in a standard module. You can run it manually after you retype a country name in D2 of the PCM sheet.

Option Explicit
Option Compare Text
Sub Create_Data_Validation()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("PCM")
    Set ws2 = Worksheets("Dropdown")
   
    Dim lr As Long, rng As Range, c As Range, Vlist, topVal As String
    lr = ws2.Cells(Rows.Count, 1).End(3).Row
    Set rng = ws2.Range("A2:A" & lr)
   
    Dim country As String
    country = ws1.Range("D2")
   
    'Check to see if country exists
    If IsError(Application.Match(country, rng, 0)) Then
        MsgBox "The country " & country & " isn't on your dropdown list"
        Exit Sub
    End If
   
    topVal = rng.Find(what:=country, after:=rng.Cells(1, 1)).Offset(, 1).Value
   
    For Each c In rng
        If c = country Then
            Vlist = Application.TextJoin(",", True, Vlist, c.Offset(, 1).Value)
        End If
    Next c
   
    With ws1.Range("E2")
        .Validation.Delete
        .Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
        Formula1:=Vlist
        .Value = topVal
        .Select
    End With
End Sub

If you want the code to run automatically whenever you change the value in D2 of the PCM sheet, put the following code in the sheet code area of the PCM sheet (right-click the sheet tab name, select view code - put it in the area on the right)

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge = 1 And Not Intersect(Range("D2"), Target) Is Nothing Then
        Create_Data_Validation
    End If
End Sub