Excel VBA_多级动态数据有效性设置实例集锦

Dim t, Arr, d

Dim i&, x$, Brr, y$

Set d = CreateObject(\Arr = Sheet10.[f1].CurrentRegion For i = 2 To UBound(Arr) x = Arr(i, 1): y = Arr(i, 2)

If d.exists(x) = False Then Set d(x) = CreateObject(\ d(x)(y) = y Next

If Target.Column = 4 Then With Target.Validation .Delete

.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, Formula1:=Join(d.keys, \ End With

Target.Offset(0, 2) = \Else

x = Target.Offset(0, -2).Value If d.exists(x) Then t = d(x).keys

With Target.Validation .Delete

.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _

Operator:=xlBetween, Formula1:=IIf(UBound(t) <> -1, Join(t, \ End With Else

Target = \ End If End If End Sub

26，5级动态数据有效性（字典套字典）

‘2013-4-10

Public D1 As New Dictionary Public D2 As New Dictionary Public D3 As New Dictionary Public D4 As New Dictionary Public D As New Dictionary, k Sub yyaa()

Dim i&, Arr, xx, yy, zz, aa, bb, cp, fl, xh Arr = Sheet6.[a1].CurrentRegion

On Error Resume Next For i = 2 To UBound(Arr) D(Arr(i, 2)) = \ xx = Arr(i, 2) yy = Arr(i, 3) zz = Arr(i, 4) aa = Arr(i, 5) bb = Arr(i, 6) fl = xx & yy xh = fl & zz dy = xh & aa

If D1.Exists(xx) = False Then Set D1(xx) = New Dictionary D1(xx)(yy) = yy

If D2.Exists(fl) = False Then Set D2(fl) = New Dictionary D2(fl)(zz) = zz

If D3.Exists(xh) = False Then Set D3(xh) = New Dictionary D3(xh)(aa) = aa

If D4.Exists(dy) = False Then Set D4(dy) = New Dictionary D4(dy)(bb) = bb Next

k = D.Keys End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Count > 1 Then Exit Sub

If Target.Column > 5 Or Target.Row < 2 Then Exit Sub On Error Resume Next Dim k1, k2, k3, k4 Dim i&, j&

Call yyaa

Select Case Target.Column Case 1

With Target.Validation .Delete

.Add 3, 1, 1, Join(k, \ End With

Target.Offset(0, 1).Resize(1, 4) = \ Case 2

If Target.Offset(0, -1) <> \

k1 = D1(Target.Offset(0, -1).Value).Keys With Target.Validation .Delete

.Add 3, 1, 1, Join(k1, \

End With

Target.Offset(0, 1).Resize(1, 3) = \ End If Case 3

If Target.Offset(0, -1) <> \

k2 = D2(Target.Offset(0, -2).Value & Target.Offset(0, -1).Value).Keys With Target.Validation .Delete

.Add 3, 1, 1, Join(k2, \ End With

Target.Offset(0, 1).Resize(1, 2) = \ End If Case 4

If Target.Offset(0, -1) <> \\

k3 = D3(Target.Offset(0, -3).Value & Target.Offset(0, -2).Value & Target.Offset(0, -1).Value).Items

With Target.Validation .Delete

.Add 3, 1, 1, Join(k3, \ End With

Target.Offset(0, 1) = \ End If Case 5

If Target.Offset(0, -1) <> \\

k4 = D4(Target.Offset(0, -4).Value & Target.Offset(0, -3).Value & Target.Offset(0, -2).Value & Target.Offset(0, -1).Value).Keys With Target.Validation .Delete

.Add 3, 1, 1, Join(k4, \ End With End If End Select

End Sub

27，4级动态数据有效性（字典数组）

‘http://club.excelhome.net/thread-1127723-1-1.html ‘2014-6-8

Dim rng As Range, Arr, d(1 To 4), d1(1 To 4), k(1 To 4), t(1 To 4)

Private Sub Worksheet_Change(ByVal Target As Range) Set rng = Union([d8], [g8], [j8], [m8], [d13], [g13], [j13]) If Intersect(rng, Target) Is Nothing Then Exit Sub If Target = \

Application.EnableEvents = False Select Case Target.Offset(0, -1).Value Case \组 织\ b = Target.Value

Target = d(1)(CStr(b)) Case \公 司\ b = Target.Value Target = d(2)(b) Case \上级部门\ b = Target.Value Target = d(3)(b) Case \部 门\ b = Target.Value Target = d(4)(b) End Select

Application.EnableEvents = True End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim aa$, i, j

Set rng = Union([d8], [g8], [j8], [m8], [d13], [g13], [j13]) If Intersect(rng, Target) Is Nothing Then Exit Sub For i = 1 To 4

Set d(i) = CreateObject(\ Set d1(i) = CreateObject(\Next

Arr = Sheet2.[i5].CurrentRegion For j = 1 To UBound(Arr, 2) Step 2 For i = 5 To UBound(Arr) If Arr(i, j) <> \

d((j + 1) / 2)(Arr(i, j)) = Arr(i, j + 1) d1((j + 1) / 2)(Arr(i, j + 1)) = Arr(i, j) End If Next Next

For i = 1 To 4

k(i) = d(i).keys: t(i) = d(i).items Next

aa = \

Select Case Target.Offset(0, -1).Value