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, \