实现Excel中多选择Category关联多选择Subcategory的动态下拉列表

需求 #

• 第一列（Category）：已通过VBA实现多选下拉列表
• 第二列（Subcategory）：需关联第一列选中的所有Category，展示对应全部Subcategory，同时支持多选（当前仅支持单Category关联，且无法多选Subcategory）

样本数据 #

解决方案 #

1. 工作表事件代码（处理多选逻辑） #

在Data Entry工作表的代码窗口中粘贴以下代码，同时处理两列的多选：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Oldvalue As String
    Dim Newvalue As String
    Application.EnableEvents = True
    On Error GoTo Exitsub
    
    ' 处理第一列（Category）和第二列（Subcategory）的多选
    If (Target.Column = 1 Or Target.Column = 2) And (Target.Row >= 2 And Target.Row <= 21) Then
        If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
            GoTo Exitsub
        Else
            If Target.Value = "" Then GoTo Exitsub
            Application.EnableEvents = False
            Newvalue = Target.Value
            Application.Undo
            Oldvalue = Target.Value
            
            If Oldvalue = "" Then
                Target.Value = Newvalue
            Else
                If InStr(1, Oldvalue, Newvalue) = 0 Then
                    Target.Value = Oldvalue & vbNewLine & Newvalue
                Else
                    Target.Value = Oldvalue
                End If
            End If
        End If
    End If
    
Exitsub:
    Application.EnableEvents = True
End Sub

2. 模块函数代码（生成关联下拉选项） #

插入一个新的标准模块，粘贴以下代码：

Sub Tester() ' 调试用
    Debug.Print getOptions().Address
End Sub

Function getOptions() As Range
    Dim c As Range, dict As Object, rw As Range, rngVals As Range, sz As Long
    
    Set rngVals = ListsSheet.Range("F6")
    rngVals.Resize(100).ClearContents   ' 清空之前的选项
    
    Set c = Application.Caller ' 获取触发下拉的单元格
    Set rw = c.EntireRow
    
    Select Case c.Column
        Case 1: Set dict = GetMainCategory() ' 第一列返回所有Category
        Case 2: Set dict = GetSubcategory(rw.Cells(1).Value) ' 第二列根据第一列选中的所有Category返回对应Subcategory
        Case Else: Set dict = CreateObject("scripting.dictionary")
    End Select
    
    If dict.Count > 0 Then
        rngVals.Cells(1).Resize(dict.Count, 1).Value = Application.Transpose(dict.keys)
    End If
    sz = IIf(dict.Count = 0, 1, dict.Count)
    Set getOptions = rngVals.Resize(sz)
End Function

' 返回存储列表数据的工作表
Function ListsSheet() As Worksheet
    Set ListsSheet = ThisWorkbook.Sheets("Lists")
End Function

' 获取所有唯一的Category
Function GetMainCategory() As Object
    Set GetMainCategory = Uniques(ListsSheet.ListObjects("Table1").DataBodyRange, 1)
End Function

' 根据选中的多个Category获取对应的所有唯一Subcategory
Function GetSubcategory(selectedCats As String) As Object
    Dim dict As Object, catArr As Variant, i As Integer
    Set dict = CreateObject("scripting.dictionary")
    
    ' 拆分选中的多个Category（按换行分隔）
    catArr = Split(selectedCats, vbNewLine)
    
    ' 遍历每个Category，收集对应的Subcategory
    For i = LBound(catArr) To UBound(catArr)
        Dim subDict As Object
        Set subDict = Uniques(ListsSheet.ListObjects("Table1").DataBodyRange, 2, 1, Trim(catArr(i)))
        ' 合并到总字典（自动去重）
        For Each key In subDict.keys
            dict(key) = True
        Next key
    Next i
    
    Set GetSubcategory = dict
End Function

' 从指定范围中获取符合过滤条件的唯一值
Function Uniques(rng As Range, valueCol As Long, ParamArray filters() As Variant) As Object
    Dim dict As Object, arr, r As Long, filtering As Boolean
    Dim adding As Boolean, i As Long, colnum As Long, v
    Set dict = CreateObject("scripting.dictionary")
    filtering = UBound(filters) <> -1
    arr = rng.Value
    
    For r = 1 To UBound(arr, 1)
        adding = True
        If filtering Then
            For i = LBound(filters) To UBound(filters) Step 2
                colnum = filters(i)
                v = filters(i + 1)
                If arr(r, colnum) <> v Then
                    adding = False
                    Exit For
                End If
            Next i
        End If
        If adding Then dict(arr(r, valueCol)) = True
    Next r
    
    Set Uniques = dict
End Function

3. 配置数据验证 #

• 选中第一列需要设置下拉的单元格（如A2:A21），打开「数据验证」：
  • 类型选择「序列」，来源输入 =getOptions()
• 选中第二列需要设置下拉的单元格（如B2:B21），同样设置数据验证，来源输入 =getOptions()

关键修改说明 #

• GetSubcategory函数新增了对多Category的处理：将第一列选中的多行文本拆分为单个Category，逐个匹配并收集对应的Subcategory，最后合并去重
• 工作表事件代码扩展了范围，同时支持第一列和第二列的多选操作
• 保持了原有的动态下拉逻辑，通过getOptions函数动态生成下拉选项范围

内容的提问来源于stack exchange，提问作者Sydney