如何用VBA在Excel中创建Store与Region的联动唯一下拉列表

需求与现状 #

• 需求：基于表格中的Store和Region字段，在Sheet2的D4、F4单元格创建联动的唯一值下拉列表——用户选择D4的Store选项后，F4的Region选项自动更新为该Store对应的唯一Region值。
• 现状：当前仅能创建独立的唯一值下拉列表，无法实现联动效果，且创建效率较低，此前通过录制宏实现。

最终解决方案 #

结合相关思路，已搭建出可行的实现方案，分为两部分：

1. 初始化代码（Module1模块） #

该代码用于为Sheet2创建初始的Store和Region唯一值下拉列表，包含一个将集合转为数组的辅助函数：

Sub Store_Region_dropDown()
  Dim Store As Range, Region As Range
  Dim uniqueStore As Collection, uniqueRegion As Collection
  Dim uniStore As Variant, uniRegion As Variant

  '获取Sheet1中Sales表的Store和Region列数据区域
  Set Store = Worksheets("Sheet1").ListObjects("Sales").ListColumns("Store").DataBodyRange
  Set Region = Worksheets("Sheet1").ListObjects("Sales").ListColumns("Region").DataBodyRange

  Set uniqueStore = New Collection
  Set uniqueRegion = New Collection   

  '提取Store列的唯一值存入集合
  On Error Resume Next
  For Each Cell In Store.Cells
     uniqueStore.Add Cell.Value, CStr(Cell.Value)
  Next Cell
  On Error GoTo 0

  '提取Region列的唯一值存入集合
  On Error Resume Next
  For Each Cell In Region.Cells
     uniqueRegion.Add Cell.Value, CStr(Cell.Value)
  Next Cell
  On Error GoTo 0

  '将集合转为逗号分隔的字符串，用于数据验证
  uniStore = Join(CollectionToArray(uniqueStore), ",")
  uniRegion = Join(CollectionToArray(uniqueRegion), ",")

  '为Sheet2的D4设置Store下拉列表
  With Sheets("Sheet2").Range("D4").Validation
          .Delete
          .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=uniStore
  End With

  '为Sheet2的F4设置初始Region下拉列表
  With Sheets("Sheet2").Range("F4").Validation
          .Delete
          .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=uniRegion
  End With

End Sub

'辅助函数：将集合转换为数组
Public Function CollectionToArray(myCol As Collection) As Variant
    Dim result  As Variant
    Dim cnt     As Long
    ReDim result(myCol.Count - 1)

    For cnt = 0 To myCol.Count - 1
        result(cnt) = myCol(cnt + 1)
    Next cnt

    CollectionToArray = result
End Function

2. 工作表联动事件（Sheet2代码模块） #

该代码监听Sheet2中D4单元格的变更，自动更新F4的Region下拉列表为当前选中Store对应的唯一Region值：

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim filterTable As ListObject
  Dim Region As Range
  Dim uniqueRegion As Collection
  Dim uniRegion As Variant

  '仅当目标单元格为D4时触发
  If Target.Address = "$D$4" Then
  
    '基于选中的Store过滤Sales表
    Set filterTable = Sheets("Sheet1").ListObjects("Sales")
    With filterTable.Range
       .AutoFilter Field:=1, Criteria1:=Range("D4")
       '获取过滤后可见的Region列数据
       Set Region = Sheets("Sheet1").ListObjects("Sales").ListColumns("Region").DataBodyRange.SpecialCells(xlCellTypeVisible) 
    End With 
    '取消表格过滤
    filterTable.AutoFilter.ShowAllData

    '提取过滤后Region列的唯一值
    Set uniqueRegion = New Collection
    On Error Resume Next
    For Each Cell In Region.Cells
       uniqueRegion.Add Cell.Value, CStr(Cell.Value)
    Next Cell
    On Error GoTo 0

    '转为逗号分隔字符串并更新F4的下拉列表
    uniRegion = Join(Module1.CollectionToArray(uniqueRegion), ",")
    With Me.Range("F4").Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=uniRegion
    End With

  End If
End Sub

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