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