.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) = \
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