发布时间 : 星期日 文章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