Make Dynamic Dropdown List Based on Column Values with VBA

Question

How do I create a dynamic dropdown list based on a range of values in column B by using VBA code?

The data are from column B in Sheet 1. I want to make the dropdown list on cell A2 in Sheet 2.

This is the example of the data set in Sheet 1 (Name = Column A; Level = Column B)

Name	Level
John	Level 1
Mike	Level 1
Lewis	Level 2
Harry	Level 3

When one of the lists is selected it would copy the data to column B in Sheet 2.

For example: when "Level 1" is chosen, then VBA will copy John and Mike to column B in Sheet 2.

Answer 1

You don't need vba to do this. Steps:

1. use "unique" function to create a unique list of level col
2. Setup validation picklist on the cell A2 using the above unique values
3. Use "Filter" function in B2 on sheet 2 syntax => =Filter(range to return, range to lookup = A1)

Answer 2

• Right click on sheet2 tab > View Code > paste code in sheet module
• visRng is the visible range after apply fiter
• rCell is the first blank cell on Col B

Microsoft documentation:

Range.CurrentRegion property (Excel)

Worksheet.ShowAllData method (Excel)

Range.SpecialCells method (Excel)

Private Sub Worksheet_Change(ByVal Target As Range)
    With Target
        If .Address = "$A$2" Then
            If Len(.Value) > 0 Then
                Dim oSht As Worksheet: Set oSht = Sheets("Sheet1")
                If oSht.AutoFilterMode Then
                    If oSht.AutoFilter.FilterMode Then oSht.ShowAllData
                End If
                Dim rCell As Range, visRng As Range
                With oSht.Range("A1").CurrentRegion
                    .AutoFilter Field:=2, Criteria1:=Target.Value
                    On Error Resume Next
                    Set visRng = .Columns(1).Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible)
                    On Error GoTo 0
                    If Not visRng Is Nothing Then
                        Set rCell = Me.Cells(Me.Rows.Count, 2).End(xlUp)
                        If Len(rCell.Value) > 0 Then Set rCell = rCell.Offset(1)
                        Application.EnableEvents = False
                        visRng.Copy rCell
                        Application.EnableEvents = True
                        oSht.ShowAllData
                    End If
                End With
            End If
        End If
    End With
End Sub

Answer 3

Please, try the next solution, in the next way:

1. Copy the next code in the sheet code module where the list validated cell exists. To do that, right click on the respective sheet name, choose View Code and paste it in the window which appears. In this way any cell modification in the respective sheet will trigger the Change event:

Option Explicit

Private dict As Object

Private Sub Worksheet_Change(ByVal Target As Range)
  Const changedCell As String = "A2" 'address where the validated list cell exists
  If Target.address(0, 0) = changedCell Then 'the code works only if changedCell is changed...
    Dim lastRBB As Long, shNames As Worksheet, arr
    Set shNames = Worksheets("Sheet1")'set the sheet where from the data to be collected exists
    lastRBB = shNames.Range("B" & shNames.rows.count).End(xlUp).Row 'last row in column B:B
    arr = shNames.Range("A2:B" & lastRBB).Value2 'place the range in an array for faster processing
    If dict Is Nothing Then   'if the dictionary has not been loaded (yet):
        loadTheDictionary arr 'call the sub loading the dictionary
    End If

    Application.EnableEvents = False 'to avoid the event to be triggered again
      Target.Offset(0, 1).Resize(lastRBB).ClearContents 'clear more than enough rows...
      Target.Offset(0, 1).Resize(UBound(dict(Target.value)) + 1).Value2 = _
                                Application.Transpose(dict(Target.value))
    Application.EnableEvents = True  'to prepare the next change event (to be triggered)
  End If
End Sub

Sub loadTheDictionary(arr)
  Set dict = CreateObject("Scripting.Dictionary")
  Dim arrIt, i As Long
  For i = 1 To UBound(arr)
    If Not dict.Exists(arr(i, 2)) Then
        dict(arr(i, 2)) = Array(arr(i, 1))
    Else
        arrIt = dict(arr(i, 2)) 'in order to change a dictionary array item you need
                                'to extract it in a variable, to add/eliminate something
                                'then to place it back as item:
        ReDim Preserve arrIt(UBound(arrIt) + 1) 'increase the 1D array dimension with one unit
        arrIt(UBound(arrIt)) = arr(i, 1)        'place the following name in the array laste element
        dict(arr(i, 2)) = arrIt                 'load back the processed array
    End If
  Next i
End Sub

Now, try playing with selecting different options in list validated cell ("A2").

If you often change the used levels, I can also supply a piece of code able to create a such list data validated cell, placing in it the unique levels...