发布时间 : 星期一 文章Excel VBA - 多级动态数据有效性设置实例集锦更新完毕开始阅读
1，3级动态数据有效性（字典+数组）
‘http://club.excelhome.net/viewthread.php?tid=461616&pid=3017249&page=2&extra=page=1
‘07200723.xls
‘3 级都做了不重复处理，只用一个工作表选择变化事件。 Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Count > 1 Then Exit Sub
If Target.Column <> 2 And Target.Column <> 3 And Target.Column <> 1 Then Exit Sub Dim d, i&, Myr&, Arr
Set d = CreateObject(\Myr = Sheet1.[a65536].End(xlUp).Row Arr = Sheet1.Range(\If Target.Column = 1 Then
Set d = CreateObject(\ For i = 1 To UBound(Arr) d(Arr(i, 1)) = \ Next
With Target.Validation .Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, Formula1:=Join(d.keys, \
‘.Add 3, 1, 1, Join(d.keys, \
End With
Target.Offset(0, 1) = \ Target.Offset(0, 2) = \ Set d = Nothing
ElseIf Target.Column = 2 And Target.Offset(0, -1) <> \ Set d = CreateObject(\ For i = 1 To UBound(Arr)
If Arr(i, 1) = Target.Offset(0, -1).Text Then d(Arr(i, 2)) = \ End If Next i
With Target.Validation .Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, Formula1:=Join(d.keys, \ End With
Target.Offset(0, 1) = \ Set d = Nothing
ElseIf Target.Column = 3 And Target.Offset(0, -1) <> \
Set d = CreateObject(\
bb = Cells(Target.Row, 1) & \ For i = 1 To UBound(Arr)
If Arr(i, 1) & \ d(Arr(i, 3)) = \ End If Next i
With Target.Validation .Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, Formula1:=Join(d.keys, \ End With
Set d = Nothing End If End Sub
2，3级动态数据有效性（数组）
‘下拉菜单设置1019.xls
‘http://club.excelhome.net/viewthread.php?tid=487842&page=1#pid3237573 Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Count > 1 Then Exit Sub
If Target.Column <> 2 And Target.Column <> 3 And Target.Column <> 4 Then Exit Sub If Target.Row < 3 Then Exit Sub
Dim d, i&, Myr&, Arr, cj, cp, jg, r1, n&, ii& Dim cjia$, cpin$, Myr1&, r%, Arr1(), j& Set d = CreateObject(\Myr = Sheet1.[g65536].End(xlUp).Row Arr = Sheet1.Range(\If Target.Column = 2 Then For i = 1 To UBound(Arr) cj = cj & Arr(i, 1) & \ Next
cj = Left(cj, Len(cj) - 1) With Target.Validation .Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, Formula1:=cj End With
Target.Offset(0, 1) = \ Target.Offset(0, 2) = \
ElseIf Target.Column = 3 And Target.Offset(0, -1) <> \ Set r1 = Range(\
n = r1.Row - 2
If Not r1 Is Nothing Then
For i = 2 To UBound(Arr, 2) If Arr(n, i) <> \
cp = cp & Arr(n, i) & \ End If Next
cp = Left(cp, Len(cp) - 1) End If
With Target.Validation .Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, Formula1:=cp End With
Target.Offset(0, 1) = \
ElseIf Target.Column = 4 And Target.Offset(0, -1) <> \ cjia = Target.Offset(0, -2) cpin = Target.Offset(0, -1)
Myr1 = Sheet1.[n65536].End(xlUp).Row For i = 3 To Myr1
If Cells(i, 13) <> Cells(i - 1, 13) And Cells(i, 13) <> \ r = r + 1
ReDim Preserve Arr1(1 To r) Arr1(r) = i End If Next i
For j = 1 To r
If Cells(Arr1(j), 13) = cjia And Cells(Arr1(j), 14) = cpin Then If j <> r Then
For ii = Arr1(j) To Arr1(j + 1) - 1 jg = jg & Cells(ii, 15) & \ Next Else
For ii = Arr1(j) To Myr1
jg = jg & Cells(ii, 15) & \ Next End If
jg = Left(jg, Len(jg) - 1) End If Next
With Target.Validation .Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, Formula1:=jg
End With End If End Sub 注：把列单元格区域转为一维数组cj = Join(Application.Transpose([b5].Resize(Myr - 4, 1)), \或者cj = Join([Transpose(b5:b50)], \
3，1级动态数据有效性（自定义）
‘http://club.excelhome.net/viewthread.php?tid=526718&pid=3473467&page=1&extra=page=1
‘VBA控制有效性.xls
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub
If Target.Address <> \If Target.Value = \有限制\ With [a1:a5].Validation .Delete
.Add Type:=xlValidateCustom, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:=\ End With Else
With [a1:a5].Validation .Delete End With End If End Sub
4，合并单元格动态数据有效性
‘用选择，Selection
If Target.Address = \ Target.Select
With Selection.Validation .Delete
.Add 3, 1, 1, Join(d.keys, \ End With
[m2] = \
‘http://club.excelhome.net/viewthread.php?tid=536836&pid=3551489&page=1&extra=page=