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=