发布时间 : 星期一 文章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) = \