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

Range(\ Else

Range(\alidateList, , , m 'DiffList(Range(ss)) End If End If

Case Range(\

If Not Range(\ s = 0 e = 0

For i = 2 To u

If Cells(i, 7).Value = Range(\ If Cells(i, 7).Value <> Range(\ e = i - 1 Exit For End If Next

If e = 0 Then e = u

Range(\ Range(\

Range(\ ss = Trim(\ m = DiffList(Range(ss)) If InStr(m, \

Range(\ Else

Range(\ End If End If

Case Range(\

If Not Range(\ For i = 2 To u

If Cells(i, 6).Value = Range(\And Cells(i, 7).Value = Range(\ Range(\ Exit For End If Next End If End Select End Sub

Private Sub Workbook_Open()

Range(\

Range(\xlValidateList, Sheets(1).UsedRange.Rows.Count)) End Sub

, , DiffList(Range(\&

23，2级动态数据有效性

‘2012-11-20

‘http://club.excelhome.net/forum.php?mod=viewthread&tid=946178&page=1#pid6486727 Dim d, Arr, d1

Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Count > 1 Then Exit Sub

If Target.Column <> 2 And Target.Column <> 3 Then Exit Sub If Target.Row < 2 Then Exit Sub Dim i&, c

Arr = Sheet1.UsedRange If Target.Column = 2 Then

Set d = CreateObject(\ For i = 1 To UBound(Arr, 2)

If Arr(1, i) <> \ Next

With Target.Validation .Delete

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

Target.Offset(0, 1) = \

ElseIf Target.Column = 3 And Target.Offset(0, -1) <> \ Set d1 = CreateObject(\ c = d(Target.Offset(0, -1).Value) d.RemoveAll

For i = 2 To UBound(Arr)

If Arr(i, c) <> \ Next i

With Target.Validation .Delete

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

24，3级右键动态菜单（字典套字典）

‘http://club.excelhome.net/thread-948085-2-1.html ‘2012-11-25 ‘模块代码

Public D1 As New Dictionary Public D2 As New Dictionary Public D As New Dictionary, k Sub 输入()

Dim cc As CommandBarButton

Set cc = Application.CommandBars.ActionControl Arr = Split(cc.HelpFile, \ ActiveCell = Arr(0)

ActiveCell.Offset(0, 1) = Arr(1) ActiveCell.Offset(0, 3) = Arr(2) ActiveCell.Offset(0, 1).Select End Sub Sub yyaa()

Dim i&, Arr, xx, yy, zz, aa, cp, fl Arr = Sheet1.[a1].CurrentRegion On Error Resume Next For i = 2 To UBound(Arr) If Arr(i, 1) <> \小计\ D(Arr(i, 1)) = \ xx = Arr(i, 1)

yy = Arr(i, 2) & \ zz = Arr(i, 4) & \

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

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

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

k = D.Keys End Sub ‘工作表代码

Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Count > 1 Then Exit Sub

If Target.Column <> 3 Or Target.Row < 3 Then Exit Sub Target.Offset(0, 1) = \On Error Resume Next Dim k1, k2

Dim i&, j&

Dim Pop() 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)

Set myBtn = Pop(j).Controls.Add(msoControlButton) With myBtn

.Caption = k2(y)

.HelpFile = k(i) & \ .OnAction = \输入\ End With Next Next End With Next

.ShowPopup '显示工具栏 End With

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

25，2级动态数据有效性（字典套字典）

‘2013-3-19

‘http://club.excelhome.net/thread-922132-1-1.html

Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Count > 1 Then Exit Sub

If (Target.Column <> 4 And Target.Column <> 6) Or Target.Row < 2 Then Exit Sub