使用VBA创建相关联的数据有效性列表

Sub test()
 Dim var As Variant, x As Long, col As New Collection, c As Variant
 Dim CountryVar As Variant, y As Long, CountryStr As String
 
 var = Sheet1.Range("A2:G" & Sheet1.Range("A" & Rows.Count).End(xlUp).Row)
 
 For x = 1 To UBound(var)
   On Error Resume Next
   col.Add var(x, 1), CStr(var(x, 1))
   On Error GoTo 0
 Next x
 
 ReDim CountryVar(col.Count - 1)
 For Each c In col
   CountryVar(y) = c
   y = y + 1
 Next c
 
 CountryStr = Join(CountryVar, ",")
 
 With Sheet2.Range("A2:A31").Validation
   .Delete
   .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=CountryStr
   .IgnoreBlank = True
   .InCellDropdown = True
   .ErrorTitle = "错误"
   .ErrorMessage = "请提供有效的输入"
   .ShowInput = True
   .ShowError = True
 End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim var As Variant, x As Long, CityVar() As Variant, y As Long
 Dim CityStr As String
 
 If Not Intersect(Target, Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)) Is Nothing Then
   If Range("A" & Target.Row) <> "" Then
     var = Sheet1.Range("A2:G" & Sheet1.Range("A" & Rows.Count).End(xlUp).Row)
 
     For x = 1 To UBound(var)
       If var(x, 1) = Range("A" & Target.Row) Then
         ReDim Preserve CityVar(y)
         CityVar(y) = var(x, 7)
         y = y + 1
       End If
     Next x
     CityStr = Join(CityVar, ",")
 
     With Target.Offset(, 1).Validation
       .Delete
       .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=CityStr
       .IgnoreBlank = True
       .InCellDropdown = True
       .ErrorTitle = "错误"
       .ErrorMessage = "请提供有效的输入"
       .ShowInput = True
       .ShowError = True
     End With
   End If
 End If
End Sub