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
Case \组 织\
For i = 0 To UBound(k(1)) aa = aa & k(1)(i) & \ Next
With Target.Validation .Delete
.Add 3, 1, 1, aa End With Case \公 司\
If Target.Row = 13 Then With Target.Validation .Delete
.Add 3, 1, 1, Join(k(2), \ End With Else
bm = d1(1)([d8].Value) For i = 0 To UBound(k(2))
If Left(k(2)(i), 4) = bm Then aa = aa & k(2)(i) & \ Next
With Target.Validation .Delete
.Add 3, 1, 1, aa End With End If
Case \上级部门\
If Target.Row = 13 Then bm = d1(2)([d13].Value) For i = 0 To UBound(k(3))
If Left(k(3)(i), 6) = bm Then aa = aa & k(3)(i) & \ Next
With Target.Validation .Delete
If aa <> \ End With Else
bm = d1(2)([g8].Value) For i = 0 To UBound(k(3))
If Left(k(3)(i), 6) = bm Then aa = aa & k(3)(i) & \ Next
With Target.Validation .Delete
If aa <> \ End With End If
Case \部 门\
If Target.Row = 13 Then bm = d1(3)([g13].Value) For i = 0 To UBound(k(4))
If Left(k(4)(i), 8) = bm Then aa = aa & k(4)(i) & \ Next
With Target.Validation .Delete
If aa <> \ End With Else
bm = d1(3)([j8].Value) For i = 0 To UBound(k(4))
If Left(k(4)(i), 8) = bm Then aa = aa & k(4)(i) & \ Next
With Target.Validation .Delete
If aa <> \ End With End If End Select End Sub
28，3级动态数据有效性多选（列表框）
‘2014-8-4
‘http://club.excelhome.net/forum.php?mod=viewthread&tid=1142144&page=1#pid7787045 Dim d, Arr
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Dim i&, Myr&, col% Myr = ActiveCell.Row
col = ActiveCell.Column + 1
For i = 0 To ListBox1.ListCount - 1 If ListBox1.Selected(i) Then
Cells(Myr, col) = Cells(Myr, col) & ListBox1.List(i) & vbCrLf End If Next
ListBox1.Visible = False End Sub
Private Sub Worksheet_Change(ByVal Target As Range)