发布时间 : 星期六 文章Excel VBA_多级动态数据有效性设置实例集锦更新完毕开始阅读
With .Controls.Add(msoControlPopup, 1, , , 1) .BeginGroup = True .Caption = k(i) aa = Split(t(i), \
For j = 0 To UBound(aa)
Set oCtrl = .Controls.Add(Type:=msoControlButton) With oCtrl
.Caption = Arr(aa(j), 2)
.HelpFile = k(i) ‘引用Helpfile属性得到上一级菜单的Caption .OnAction = \输入1\ End With Next End With Else
With .Controls.Add(Type:=msoControlButton) .Caption = k(i)
.BeginGroup = True
.Style = msoButtonIconAndCaption .OnAction = \输入\ End With End If Next
.ShowPopup '显示工具栏 End With
Application.CommandBars(\临时菜单\删除工具栏 [b3].Select End Sub
模块1代码： Public d1, d
Sub 输入() '当单击一级菜单时，将菜单的标题字符写入单元格 aa = CommandBars.ActionControl.Caption n = d(Val(aa))
n = Left(n, Len(n) - 1) [b4] = aa
[c4] = Sheet1.Cells(n + 18, 3) [d4] = Sheet1.Cells(n + 18, 4) [e4] = Sheet1.Cells(n + 18, 5) [g4] = Sheet1.Cells(n + 18, 6) End Sub
Sub 输入1() '当单击二级菜单时，将菜单的标题字符写入单元格
nm = CommandBars.ActionControl.HelpFile ‘引用Helpfile属性得到上一级菜单的Caption aa = CommandBars.ActionControl.Caption n = d1(nm & \
n = Left(n, Len(n) - 1)
[b4] = Sheet1.Cells(n + 18, 2) [c4] = Sheet1.Cells(n + 18, 3) [d4] = Sheet1.Cells(n + 18, 4) [e4] = Sheet1.Cells(n + 18, 5) [g4] = Sheet1.Cells(n + 18, 6) End Sub
21，4级右键动态菜单（字典套字典）
‘http://club.excelhome.net/thread-911284-1-2.html ‘20120827
Sub myBtn_click()
Dim cc As CommandBarButton Dim Arr
Set cc = Application.CommandBars.ActionControl Arr = Split(cc.HelpFile, \ ActiveCell = Arr(0)
ActiveCell.Offset(1, 0) = Arr(1) ActiveCell.Offset(2, 0) = Arr(2) ActiveCell.Offset(3, 0) = Arr(3) ActiveCell.Offset(1, 0).Select End Sub
Sub Create_popup()
Dim i As Long, Arr, n&, n1& CommandBars(\ Dim mybar As CommandBar
Set mybar = Application.CommandBars.Add(\ mybar.Height = 500 mybar.Width = 400
Dim myPop As CommandBarPopup Dim myBtn As CommandBarButton Dim Pop() As CommandBarPopup Dim Pop1() As CommandBarPopup Dim d, dc, dc1
Set d = CreateObject(\ Set dc = CreateObject(\ Set dc1 = CreateObject(\ n = 1: n1 = 1
With Sheets(\
Arr = .[f1].CurrentRegion For i = 2 To UBound(Arr)
If Not d.exists(Arr(i, 1)) Then d(Arr(i, 1)) = \
Set myPop = mybar.Controls.Add(msoControlPopup, , , , True) myPop.Caption = Arr(i, 1) End If
xx = Arr(i, 1) & Arr(i, 2)
yy = Arr(i, 1) & Arr(i, 2) & Arr(i, 3) If Not dc.exists(xx) Then dc.Add xx, n
ReDim Preserve Pop(n) As CommandBarPopup
Set Pop(n) = myPop.Controls.Add(msoControlPopup, , , , True) Pop(n).Caption = Arr(i, 2) n = n + 1 End If
If Not dc1.exists(yy) Then dc1.Add yy, n1
ReDim Preserve Pop1(n1) As CommandBarPopup
Set Pop1(n1) = Pop(dc.Item(xx)).Controls.Add(msoControlPopup, , , , True)
Pop1(n1).Caption = Arr(i, 3) n1 = n1 + 1 End If
Set myBtn = Pop1(dc1.Item(yy)).Controls.Add(msoControlButton) myBtn.Caption = Arr(i, 4)
myBtn.HelpFile = Arr(i, 1) & \4)
myBtn.Style = msoButtonCaption myBtn.OnAction = \ Next End With
Set myBtn = Nothing: Set myPop = Nothing: Set mybar = Nothing Set d = Nothing: Set dc = Nothing: Set dc1 = Nothing Erase Pop: Erase Pop1 End Sub
22，4级动态菜单（自定义函数）by:tennicse
‘http://club.excelhome.net/forum.php?mod=viewthread&tid=911284&page=2#pid6252644 ‘by:tennicse
Public Function DiffList(ByRef Source As Range) As String
Set AA = New Collection
For i = 1 To Source.Rows.Count b = False
For Each s In AA
If s = Source.Cells(i, 1).Value Then b = True Exit For End If Next
If Not b Then AA.Add Source.Cells(i, 1).Value Next s = \
For i = 1 To AA.Count s = s & \ Next
s = Right(s, Len(s) - 1) Set AA = Nothing DiffList = s End Function
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub u = Sheets(1).UsedRange.Rows.Count Select Case Target
Case Range(\
If Not Range(\ s = 0 e = 0
For i = 2 To u
If Cells(i, 6).Value = Range(\ If Cells(i, 6).Value <> Range(\ e = i - 1 Exit For End If Next
If e = 0 Then e = u
Range(\ Range(\ Range(\
Range(\ Range(\ ss = Trim(\ m = DiffList(Range(ss)) If InStr(m, \