ElseIf Target.Column = 3 And Target.Offset(0, -1) <> \ Set d = CreateObject(\
bb = Cells(Target.Row, 1) & \ For i = 0 To UBound(Arr, 2)
If Arr(1, i) & \ If Arr(3, i) <> \ d(Arr(3, i)) = \ End If End If Next i
On Error Resume Next k = d.keys
If d.Count = 0 Then GoTo 100
If d.Count = 1 Then Target = k(0): GoTo 100 With Target.Validation .Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, Formula1:=Join(k, \ End With 100:
Set d = Nothing End If End Sub
13， ADO+GetRows根据Access数据库的字段名，设置2级动态数据有效性
‘http://club.excelhome.net/thread-672437-1-1.html Public Arr, Brr Sub yy()
Dim mydata$, mytable$, SQL$, cnn, y, zz
mydata = ThisWorkbook.Path & \数据库.mdb\ mytable = \数据\
Set cnn = CreateObject(\ With cnn
.Provider = \ .Open mydata End With
SQL = \
Arr = cnn.Execute(SQL).GetRows Set y = cnn.Execute(SQL)
ReDim Brr(1 To y.Fields.Count) For Each zz In y.Fields i = i + 1
Brr(i) = zz.Name Next
cnn.Close
Set cnn = Nothing End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Count > 1 Then Exit Sub
If Target.Column <> 2 And Target.Column <> 1 Then Exit Sub Dim d, i&, Myr&, aa$, j& If Target.Column = 1 Then With Target.Validation .Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, Formula1:=Join(Brr, \ End With
Target.Offset(0, 1) = \
ElseIf Target.Column = 2 And Target.Offset(0, -1) <> \ For i = 1 To UBound(Brr)
If Brr(i) = Target.Offset(0, -1).Text Then For j = 0 To UBound(Arr, 2) aa = aa & Arr(i - 1, j) & \ Next End If Next i
aa = Left(aa, Len(aa) - 1) With Target.Validation .Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, Formula1:=aa End With End If End Sub
14，4级动态数据有效性（字典套字典）
‘http://club.excelhome.net/viewthread.php?tid=693362&pid=4720311&page=1&extra=page=1
‘日报表4级数据有效性0316.rar
Dim D1 As New Dictionary Dim D2 As New Dictionary Dim D3 As New Dictionary Dim D4 As New Dictionary
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Count > 1 Then Exit Sub If Target.Row < 17 Then Exit Sub If Target.Column > 4 Then Exit Sub Dim n As Long, i As Long, Arr, t1, k1 n = Sheet1.[i65536].End(xlUp).Row Arr = Sheet1.[i1].Resize(n, 4) On Error Resume Next For i = 2 To n
D4.Add Arr(i, 1) & \ xx = Arr(i, 1) & \ yy = Arr(i, 2) & \ zz = Arr(i, 3) & \ aa = Arr(i, 4) & \
cp = Arr(i, 1) & Arr(i, 2)
xh = Arr(i, 1) & Arr(i, 2) & Arr(i, 3)
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(xh) = False Then Set D3(xh) = New Dictionary D3(xh)(aa) = \Next
If Target.Column = 1 Then With Target.Validation .Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, Formula1:=Join(D4.Keys, \ End With
Target.Offset(0, 1) = \ Target.Offset(0, 2) = \ Target.Offset(0, 3) = \
ElseIf Target.Column = 2 Then With Target.Validation .Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:=Join(D1(Target.Offset(0, -1).Value).Keys, \ End With
Target.Offset(0, 1) = \ Target.Offset(0, 2) = \ElseIf Target.Column = 3 Then
‘k1 = D2(Target.Offset(0, -2).Value & Target.Offset(0, -1).Value).Keys ‘t1 = D2(Target.Offset(0, -2).Value & Target.Offset(0, -1).Value).Items With Target.Validation .Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:=Join(D2(Target.Offset(0, -2).Value & Target.Offset(0, -1).Value).Keys, \ End With
Target.Offset(0, 1) = \Else
With Target.Validation .Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:=Join(D3(Target.Offset(0, -3).Value & Target.Offset(0, -2).Value & Target.Offset(0, -1).Value).Keys, \ End With End If End Sub
‘4级快捷菜单任务单0306.xls ‘模块1中
Public D1 As New Dictionary Public D2 As New Dictionary Public D3 As New Dictionary Public D As New Dictionary, k Sub 输入()
Dim cc As CommandBarButton, aa, i&
Set cc = Application.CommandBars.ActionControl ActiveCell.Resize(1, 8) = \ aa = Split(cc.HelpFile, \ ActiveCell = aa(0)
[h22] = aa(1): [j22] = aa(2): [l22] = aa(3) [d9].Select 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)
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) = \Next
k = D.Keys End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address <> \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 ‘Application.ScreenUpdating = False 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)