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

.Add(msoControlButton, CommandBars(\ .Controls(\

Set newButton = customBar.Controls _

.Add(msoControlButton, CommandBars(\ .Controls(\

Set newButton = customBar.Controls _

.Add(msoControlButton, CommandBars(\ .Controls(\customBar.Visible = True

16，2级动态数据有效性（快捷菜单

CommandBarPopup）

‘创建多级下拉菜单036.xls

Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Count > 1 Then Exit Sub '如果选择区域则退出 If Target.Column <> 2 Then Exit Sub

If Target.Row < 2 And Target.Row > 11 Then Exit Sub On Error Resume Next Dim sht As Worksheet

Set sht = Sheets(\数据\将数据表赋予变量sht If err <> 0 Then err.Clear: Exit Sub

'如果有错误（即没有“数据”工作表）那么退出

If sht.Range(\请在数据表中输入数据，必须从A1开始，数据区不要留空\提示\ 'Dim a As Range

Dim i, j, addss As String

With Application.CommandBars.Add(\临时菜单\ '创建一个快捷菜单

With .Controls.Add(Type:=msoControlButton) '添加一个子菜单 .Caption = \请选择\指定显示标题 .FaceId = 136 '指定图标 End With

For i = 1 To sht.Cells(1, Columns.Count).End(xlToLeft).Column '创建一级菜单

If WorksheetFunction.CountA(sht.Rows(2)) = 0 Then '如果第二行为空则只创建一级菜单

With .Controls.Add(Type:=msoControlButton) '开始创建一级菜单 .Caption = sht.Cells(1, i).Text '菜单显示的标题

.Style = msoButtonIconAndCaption '同时显示文本和图标

.FaceId = 70 + i '指定图文件

.OnAction = \输入\指定菜单对应的宏名 End With

Else '第二行非空则创建二级菜单

With .Controls.Add(msoControlPopup, 1, , , 1) '开如创建一级菜单 .BeginGroup = True '全部产生一条横线分隔开 .Caption = sht.Cells(1, i).Text '指定一级菜单标题 For j = 2 To sht.Cells(Rows.Count, i).End(xlUp).Row

If sht.Cells(j, i) = \如果为空则不创建子菜单

Set oCtrl = .Controls.Add(Type:=msoControlButton) '创建二级子菜单 With oCtrl '对子菜单指定标题、宏名和图标 .Caption = sht.Cells(j, i) .OnAction = \输入\ .FaceId = 69 + j End With AA:

Next End With End If Next

.ShowPopup '显示工具栏 End With

Application.CommandBars(\临时菜单\删除工具栏

End Sub

模块1中代码：

Sub 输入() '当单击二级菜单时，将菜单的标题字符写入单元格 AA = CommandBars.ActionControl.Caption '记录当前菜单的标题

'在数据表中查找变量aa，并返回找到的目标所在列的第一个单元格（即一级菜单），并写入

'活动单元格

ActiveCell = Sheets(\数据\'如果“数据”工作表第二行有数据，那么将当前菜单的文字写入右边一个单元格（即二级菜单）

If WorksheetFunction.CountA(Sheets(\数据\ ActiveCell.Offset(0, 1) = AA End If End Sub

17，2级动态数据有效性（逐步减少的数据有效性）

‘http://club.excelhome.net/viewthread.php?tid=734768&pid=4988042&page=1&extra=page=1

‘二级下拉菜单问题0625.xls

Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Count > 1 Then Exit Sub Dim i&, bp$, d

Dim Arr, yj$, col%, cp$

Set d = CreateObject(\Arr = Range(\If Target.Address = \ For i = 1 To UBound(Arr, 2) If Arr(1, i) <> \ d(Arr(1, i)) = \ End If Next

With Target.Validation .Delete

.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, Formula1:=Join(d.keys, \ End With

Target.Offset(0, 1).Resize(5, 1) = \

ElseIf Target.Column = 2 And Target.Row > 1 And Target.Row < 7 Then cp = \

yj = [a2].Value

Set r1 = Rows(1).Find(yj) col = r1.Column - 6

For i = 2 To UBound(Arr)

If Arr(i, col) <> \

cp = cp & Arr(i, col) & \ End If Next i bp = cp

For i = 2 To 6

If InStr(bp, Cells(i, 2)) > 0 Then

bp = Replace(bp, Cells(i, 2) & \ End If Next i

bp = Left(bp, Len(bp) - 1) With Target.Validation

.Delete

.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, Formula1:=bp End With End If

Set d = Nothing End Sub

18，5级右键菜单（字典套字典）

‘2011-11-2 ‘模块1代码：

‘http://club.excelhome.net/thread-783632-1-2.html 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 输入()

Dim cc As CommandBarButton

Set cc = Application.CommandBars.ActionControl ActiveCell.Offset(, 4) = cc.Caption

ActiveCell.Resize(1, 4) = Split(cc.HelpFile, \End Sub Sub yyaa()

Dim i&, Arr, xx, yy, zz, aa, bb, cp, fl, xh Arr = Sheet2.[a1].CurrentRegion On Error Resume Next For i = 2 To UBound(Arr) D(Arr(i, 1)) = \ xx = Arr(i, 1)

yy = Arr(i, 2) & \ zz = Arr(i, 3) & \ aa = Arr(i, 4) & \ bb = Arr(i, 5) & \

cp = Arr(i, 1) & Arr(i, 2)

fl = Arr(i, 1) & Arr(i, 2) & Arr(i, 3)

xh = Arr(i, 1) & Arr(i, 2) & Arr(i, 3) & Arr(i, 4)

If D1.Exists(xx) = False Then Set D1(xx) = New Dictionary D1(xx)(yy) = \

If D2.Exists(cp) = False Then Set D2(cp) = New Dictionary D2(cp)(zz) = \