发布时间 : 星期一 文章Excel VBA_多级动态数据有效性设置实例集锦更新完毕开始阅读
If D3.Exists(fl) = False Then Set D3(fl) = New Dictionary D3(fl)(aa) = \
If D4.Exists(xh) = False Then Set D4(xh) = New Dictionary D4(xh)(bb) = \Next
k = D.Keys End Sub
‘sheet1中代码：
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Count > 1 Then Exit Sub '如果选择区域则退出 If Target.Column <> 1 Or Target.Row < 2 Then Exit Sub On Error Resume Next
Dim sht As Worksheet, k1, k2, k3, k4 Set sht = Sheets(\库存\Dim i&, j&
Dim Pop() As CommandBarPopup Dim Pop1() As CommandBarPopup Dim Pop2() As CommandBarPopup
Call yyaa
With Application.CommandBars.Add(\临时菜单\ With .Controls.Add(Type:=msoControlButton) .Caption = \请选择\ .FaceId = 136 End With
For i = 0 To UBound(k) k1 = D1(k(i)).Keys
With .Controls.Add(msoControlPopup, 1, , , 1) .BeginGroup = True .Caption = k(i)
For j = 0 To UBound(k1)
k2 = D2(k(i) & k1(j)).Keys
ReDim Preserve Pop(j) As CommandBarPopup
Set Pop(j) = .Controls.Add(msoControlPopup, , , , True) Pop(j).Caption = k1(j) For x = 0 To UBound(k2)
k3 = D3(k(i) & k1(j) & k2(x)).Keys
ReDim Preserve Pop1(x) As CommandBarPopup
Set Pop1(x) = Pop(j).Controls.Add(msoControlPopup, , , , True) Pop1(x).Caption = k2(x) For y = 0 To UBound(k3)
k4 = D4(k(i) & k1(j) & k2(x) & k3(y)).Keys ReDim Preserve Pop2(y) As CommandBarPopup
Set Pop2(y) = Pop1(x).Controls.Add(msoControlPopup, , , , True) Pop2(y).Caption = k3(y) For z = 0 To UBound(k4)
Set myBtn = Pop2(y).Controls.Add(msoControlButton) With myBtn
.Caption = k4(z)
.HelpFile = k(i) & \ .OnAction = \输入\ .FaceId = 70 + z End With Next Next Next Next End With Next
.ShowPopup '显示工具栏 End With
Application.CommandBars(\临时菜单\删除工具栏 End Sub
19，3级动态数据有效性（字典+数组+合并单元格）
‘http://www.excelpx.com/thread-223000-1-1.html ‘20120217
Public Myr&, d, k, Arr
Private Sub Worksheet_selectionChange(ByVal Target As Range) If Target.Count > 1 Then Exit Sub If Target.Column <> 7 Then Exit Sub If Target.Row < 2 Then Exit Sub Dim alist$, i&
Myr = Sheet1.[a65536].End(xlUp).Row Arr = Sheet1.Range(\
Set d = CreateObject(\For i = 1 To UBound(Arr) d(Arr(i, 1)) = \Next
k = d.keys
alist = Join(k, \
With Target.Validation .Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, Formula1:=alist End With
Target.Offset(0, 1) = \
Target.Offset(0, 2) = \End Sub
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub
If Target.Column <> 8 And Target.Column <> 7 Then Exit Sub If Target.Row < 2 Then Exit Sub Dim aa$, bb$
If Target <> \
If Target.Column = 7 Then For i = 1 To UBound(Arr)
If Arr(i, 1) = Target.Value Then d(Arr(i, 2)) = \ End If Next i Else
Target.Offset(0, 1) = \ For i = 1 To UBound(Arr)
If Arr(i, 2) = Target.Value And Arr(i, 1) = Target.Offset(0, -1).Value Then d(Arr(i, 3)) = \ End If Next i End If k = d.keys
If d.Count > 1 Then
With Target.Offset(0, 1).Validation .Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, Formula1:=Join(d.keys, \ End With Else
Target.Offset(0, 1) = k(0) End If
d.RemoveAll End If End Sub
‘http://club.excelhome.net/thread-654547-2-1.html
有2列是合并单元格的情况
Public Myr&, d, Arr, d1, d2
Private Sub Worksheet_selectionChange(ByVal Target As Range) If Target.Count > 1 Then Exit Sub If Target.Column <> 12 Then Exit Sub If Target.Row < 2 Then Exit Sub Dim i&
Myr = Sheet17.Cells(Rows.Count, 4).End(xlUp).Row Arr = Sheet17.Range(\
Set d = CreateObject(\For i = 2 To UBound(Arr)
If Arr(i, 2) <> \Next
With Target.Validation .Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, Formula1:=Join(d.keys, \ End With
Target.Offset(0, 1).Resize(1, 2) = \End Sub
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub If Target = \If Target.Row < 2 Then Exit Sub Dim n, n1, m&, j&
Set d1 = CreateObject(\Set d2 = CreateObject(\
If Target.Column = 12 Then For i = 2 To UBound(Arr)
If Arr(i, 2) <> \ Next
n = d(Target.Value)
If Sheet17.Cells(n, 2).MergeCells Then
m = Sheet17.Cells(n, 2).MergeArea.Count For j = n To n + m - 1
If Arr(j, 3) <> \ Next Else
d1(Arr(n, 3)) = n