Kode VBA cascading dropdown

Pada kasus ini saya memiliki sheet Data_Daerah berisi kolom Provinsi Kabupaten Kecamatan Desa Kode_Pos. Saya ingin membuat form input di Sheet Identitas, dengan ketentuan :

• Provinsi (cell D11) akan muncul dropdown otomatis berisi data provinsi dari Data_Daerah, hindari data ganda.
• Kabupaten (cell D12) dropdown berisi data kabupaten dari Data_Daerah, dengan menyesuaikan provinsi yang telah dipilih di cell D11
• Kecamatan (cell D13) dropdown berisi data kecamatan dari Data_Daerah, dengan menyesuaikan yang telah dipilih di cell D12
• Desa (cell D14) dropdown berisi data desa dari Data_Daerah, dengan menyesuaikan yang telah dipilih di cell D13
• Kode Pos (cell D15) dropdown berisi data Kode Pos dari Data_Daerah, dengan menyesuaikan yang telah dipilih di cell D14

Untuk kasus seperti ini, kita perlu membuat cascading dropdown (dropdown bertingkat) di sheet Identitas, berdasarkan data di sheet Data_Daerah. Solusinya bisa dibuat dengan VBA yang otomatis mengisi Data Validation ketika user memilih data di cell tertentu.

Berikut kode VBA yang bisa digunakan :

Option Explicit

' ==== EVENT ====
Private Sub Worksheet_Activate()
    ' Pastikan daftar Provinsi selalu siap saat sheet aktif
    Build_Provinsi_DV
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("D11:D14")) Is Nothing Then Exit Sub
    
    Application.EnableEvents = False
    On Error GoTo keluar
    
    Select Case Target.Address
        Case "$D$11"    ' Provinsi berubah → bangun dropdown Kabupaten, reset bawahnya
            If Len(Target.Value) = 0 Then
                ClearCellsAndValidation Range("D12:D15")
            Else
                Build_Kabupaten_DV Target.Value
                ClearCellsAndValidation Range("D13:D15")
            End If
        
        Case "$D$12"    ' Kabupaten berubah → bangun dropdown Kecamatan, reset bawahnya
            If Len(Target.Value) = 0 Then
                ClearCellsAndValidation Range("D13:D15")
            Else
                Build_Kecamatan_DV Range("D11").Value, Target.Value
                ClearCellsAndValidation Range("D14:D15")
            End If
        
        Case "$D$13"    ' Kecamatan berubah → bangun dropdown Desa, reset D15
            If Len(Target.Value) = 0 Then
                ClearCellsAndValidation Range("D14:D15")
            Else
                Build_Desa_DV Range("D11").Value, Range("D12").Value, Target.Value
                ClearCellsAndValidation Range("D15")
            End If
        
        Case "$D$14"    ' Desa dipilih → isi otomatis Kode Pos (D15)
            If Len(Target.Value) = 0 Then
                ClearCellsAndValidation Range("D15")
            Else
                Fill_KodePos Range("D11").Value, Range("D12").Value, Range("D13").Value, Target.Value
            End If
    End Select

keluar:
    Application.EnableEvents = True
End Sub

' ==== PEMBANGUN DAFTAR DROPDOWN (dengan helper sheet) ====
Private Sub Build_Provinsi_DV()
    Dim items As Collection
    Set items = UniqueList(1) ' kolom A = Provinsi
    WriteListToHelper items, 1           ' Tulis ke kolom A helper
    ApplyValidationFromHelper Range("D11"), 1, items.Count
End Sub

Private Sub Build_Kabupaten_DV(ByVal prov As String)
    Dim items As Collection
    Set items = UniqueList(2, 1, prov)   ' target: kolom B, filter A=prov
    WriteListToHelper items, 2           ' kolom B helper
    ApplyValidationFromHelper Range("D12"), 2, items.Count
End Sub

Private Sub Build_Kecamatan_DV(ByVal prov As String, ByVal kab As String)
    Dim items As Collection
    Set items = UniqueList(3, 1, prov, 2, kab)   ' target: kolom C, filter A,B
    WriteListToHelper items, 3                   ' kolom C helper
    ApplyValidationFromHelper Range("D13"), 3, items.Count
End Sub

Private Sub Build_Desa_DV(ByVal prov As String, ByVal kab As String, ByVal kec As String)
    Dim items As Collection
    Set items = UniqueList(4, 1, prov, 2, kab, 3, kec)   ' target: kolom D, filter A,B,C
    WriteListToHelper items, 4                           ' kolom D helper
    ApplyValidationFromHelper Range("D14"), 4, items.Count
End Sub

Private Sub Fill_KodePos(ByVal prov As String, ByVal kab As String, ByVal kec As String, ByVal desa As String)
    Dim ws As Worksheet, lastRow As Long, i As Long
    Set ws = ThisWorkbook.Sheets("Data_Daerah")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    Dim kode As Variant: kode = ""
    For i = 2 To lastRow
        If ws.Cells(i, 1).Value = prov _
        And ws.Cells(i, 2).Value = kab _
        And ws.Cells(i, 3).Value = kec _
        And ws.Cells(i, 4).Value = desa Then
            kode = ws.Cells(i, 5).Value   ' kolom E = Kode_Pos
            Exit For
        End If
    Next i
    
    Range("D15").Validation.Delete  ' D15 tidak pakai dropdown
    Range("D15").Value = kode
End Sub

' ==== UTILITAS DATA & VALIDATION ====
Private Function UniqueList(ByVal targetCol As Long, ParamArray FilterPairs()) As Collection
    ' targetCol: 1=Prov, 2=Kab, 3=Kec, 4=Desa, 5=Kode Pos
    ' FilterPairs: pasangan (colIndex, nilai) misal: 1,"Lampung", 2,"Lampung Timur"
    Dim ws As Worksheet, lastRow As Long, i As Long, ok As Boolean
    Set ws = ThisWorkbook.Sheets("Data_Daerah")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim fpIdx As Long, fCol As Long, fVal As Variant
    
    For i = 2 To lastRow
        ok = True
        If UBound(FilterPairs) >= 0 Then
            For fpIdx = LBound(FilterPairs) To UBound(FilterPairs) Step 2
                fCol = CLng(FilterPairs(fpIdx))
                fVal = FilterPairs(fpIdx + 1)
                If ws.Cells(i, fCol).Value <> fVal Then
                    ok = False
                    Exit For
                End If
            Next fpIdx
        End If
        
        If ok Then
            If Len(ws.Cells(i, targetCol).Value) > 0 Then
                dict(ws.Cells(i, targetCol).Value) = 1
            End If
        End If
    Next i
    
    Dim c As New Collection, k As Variant
    For Each k In dict.Keys
        c.Add k
    Next k
    Set UniqueList = c
End Function

Private Sub WriteListToHelper(ByVal items As Collection, ByVal helperCol As Long)
    Dim hs As Worksheet, r As Long, i As Long
    Set hs = EnsureHelperSheet()
    ' bersihkan kolom helper yang dipakai
    With hs
        .Range(.Cells(1, helperCol), .Cells(.Rows.Count, helperCol)).ClearContents
    End With
    
    If items Is Nothing Then Exit Sub
    If items.Count = 0 Then Exit Sub
    
    For i = 1 To items.Count
        hs.Cells(i, helperCol).Value = items(i)
    Next i
End Sub

Private Sub ApplyValidationFromHelper(ByVal targetCell As Range, ByVal helperCol As Long, ByVal itemCount As Long)
    Dim hs As Worksheet, addr As String
    Set hs = EnsureHelperSheet()
    
    With targetCell.Validation
        .Delete
        If itemCount > 0 Then
            addr = "'" & hs.Name & "'!" & hs.Range(hs.Cells(1, helperCol), hs.Cells(itemCount, helperCol)).Address
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=" & addr
        End If
    End With
End Sub

Private Function EnsureHelperSheet() As Worksheet
    Dim hs As Worksheet
    On Error Resume Next
    Set hs = ThisWorkbook.Sheets("DV_Helper")
    On Error GoTo 0
    
    If hs Is Nothing Then
        Set hs = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        hs.Name = "DV_Helper"
        hs.Visible = xlSheetVeryHidden   ' sangat tersembunyi
    End If
    
    Set EnsureHelperSheet = hs
End Function

Private Sub ClearCellsAndValidation(ByVal rng As Range)
    rng.ClearContents
    On Error Resume Next
    rng.Validation.Delete
    On Error GoTo 0
End Sub