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

End If

ks = Arr1(i) For jj = ks To js

d1(Arr(jj, 2)) = \ Next Next Else

i = d(gs)

If i <> r Then

js = Arr1(i + 1) - 1 Else

js = UBound(Arr) End If

ks = Arr1(i) For jj = ks To js

d1(Arr(jj, 2)) = \ Next End If End Sub Sub yy1(gs)

Dim aa, i&, j&, ks, js, jj&

Set d1 = CreateObject(\ If InStr(gs, \ aa = Split(gs, \

For j = 0 To UBound(aa)

b = Left(aa(j), Len(aa(j)) - 1) i = d(b)

If i <> r Then

js = Arr1(i + 1) - 1 Else

js = UBound(Arr) End If

ks = Arr1(i) For jj = ks To js

d1(Arr(jj, 2)) = \ Next Next Else

b = Left(gs, Len(gs) - 1) i = d(b)

If i <> r Then

js = Arr1(i + 1) - 1 Else

js = UBound(Arr)

End If

ks = Arr1(i) For jj = ks To js

d1(Arr(jj, 2)) = \ Next End If End Sub

31，5级展开（字典套字典）

‘2014-8-7

‘http://club.excelhome.net/thread-1143612-1-1.html Sub lqxs()

Dim i&, Arr, xx, yy, col%, j&, jb, k, k1, D As New Dictionary [h:iv].ClearContents

Arr = [a1].CurrentRegion

jb = Array(\第一级\第二级\第三级\第四级\第五级\On Error Resume Next: col = 7 For i = 2 To UBound(Arr) D(Arr(i, 1)) = \Next

k = D.Keys

col = col + 1: Cells(1, col) = jb(1)

Cells(2, col).Resize(D.Count) = Application.Transpose(k) D.RemoveAll

For j = 1 To UBound(Arr, 2) - 1 For i = 2 To UBound(Arr) xx = Arr(i, j) yy = Arr(i, j + 1)

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

k = D.Keys

For i = 0 To UBound(k)

col = col + 1: Cells(1, col) = jb(j + 1) & \ k1 = D(k(i)).Keys

Cells(2, col).Resize(D(k(i)).Count) = Application.Transpose(k1) Next

D.RemoveAll Next

End Sub