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

fanjy

发布于 2024-06-18 15:58:47

19000

代码可运行

文章被收录于专栏：完美Excel完美Excel

运行总次数：0

代码可运行

标签：VBA，数据验证

如下图1所示，当选择工作表Sheet2列A中的单元格下拉列表项后，其相邻列B中的单元格下拉列表项会与列A中选择项相关联，也就是说，列A中选择不同的项，列B中也会呈现相应的项。

图1

下图2是下拉列表项的数据源，位于工作表Sheet1的单元格区域A2:G33中。

图2

下面是实现这样效果的VBA代码。

打开VBE，插入一个标准模块，在其中输入代码：

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

在VBE中，双击Sheet2打开其代码模块，输入下面的代码：

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

运行标准模块中的test过程，即可得到图1所示的效果。

本文参与腾讯云自媒体同步曝光计划，分享自微信公众号。

原始发表：2024-06-10，如有侵权请联系 cloudcommunity@tencent.com 删除

数据