End If Next
If Target.Column = 1 Then With Target.Validation .Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, Formula1:=Join(d.keys, \ End With
Target.Offset(0, 1) = \Else
cp = d(Target.Offset(0, -1).Value) With Target.Validation .Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, Formula1:=cp End With End If End Sub
‘http://club.excelhome.net/viewthread.php?tid=572557&pid=3824288&page=1&extra=page=1
‘数据有效性0510.xls (消除空格，首选先赋值)
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Count > 1 Then Exit Sub
If Target.Column <> 4 And Target.Column <> 3 Then Exit Sub Dim d, i&, Myr&, Arr, r%, Arr1(), cp$, ks&, js&, j& Set d = CreateObject(\Myr = Sheet1.[b65536].End(xlUp).Row Arr = Sheet1.Range(\If Target.Column = 3 Then For i = 1 To UBound(Arr) If Arr(i, 1) <> \ d(Arr(i, 1)) = \ End If 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 = 4 And Target.Offset(0, -1) <> \ For i = 1 To UBound(Arr)
If Arr(i, 1) <> \ r = r + 1
ReDim Preserve Arr1(1 To r) Arr1(r) = i End If Next i
For i = 1 To r
If Arr(Arr1(i), 1) = Target.Offset(0, -1).Text Then If i <> r Then
js = Arr1(i + 1) - 1 Else
js = Myr - 1 End If
ks = Arr1(i) For j = ks To js
cp = cp & Arr(j, 2) & \ Next End If Next i
cp = Left(cp, Len(cp) - 1) With Target.Validation .Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, Formula1:=cp End With
Target = Split(cp, \End If
Set d = Nothing End Sub
9，2级动态数据有效性（ADO +组合框）
http://club.excelhome.net/viewthread.php?tid=630577&pid=4268345&page=1&extra=page=1 Private Sub ComboBox1_Change() '先引用MS ADO 2.7
Dim BtArr() As Byte, zdm$
Dim cnn As New ADODB.Connection Dim rst As New ADODB.Recordset Dim myPath As String Dim myTable As String Me.ComboBox2.Clear
zdm = Me.ComboBox1.Text
myPath = ThisWorkbook.Path & \
cnn.Open \ If Me.ComboBox1 <> \供应商\ myTable = \内容\ Else
myTable = \供应商\ End If
rst.Open \ rst.MoveFirst Do
Me.ComboBox2.AddItem rst(zdm) rst.MoveNext
Loop While Not rst.EOF Me.ComboBox2.SetFocus
End Sub
Private Sub UserForm_Initialize() Dim i As Byte For i = 1 To 5
Me.ComboBox1.AddItem Array(\供应商\单号\描述\单位\货币\Next End Sub
10，利用动态数据有效性显示表2数据 by:cm6705
‘http://club.excelhome.net/thread-643285-1-1.html
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column <> 2 Then Exit Sub Dim Rng As Range, Myr$ If Target.Count = 1 Then
Set Rng = Sheets(\表2\ If Not Rng Is Nothing Then
Myr = Sheets(\表2\ End If
If Myr <> \
With Target.Validation .Delete .Add 0
.InputMessage = Myr End With
End If End If End Sub
11，字典+ADO+GetRows设置动态数据有效性
‘http://club.excelhome.net/viewthread.php?tid=650628&pid=4415493&page=1&extra=page=1
Private Sub Workbook_Open() Dim cnn As Object Dim arr, d As Object Dim SQL As String, i&
Set cnn = CreateObject(\
cnn.Open \Properties='Excel 8.0;hdr=no';Data Source=\数据库.xls\请自己修改路径 SQL = \入库类别$a4:d65536] where f2 is not null\ arr = cnn.Execute(SQL).GetRows cnn.Close
Set cnn = Nothing
Set d = CreateObject(\ For i = 0 To UBound(arr, 2) d(arr(1, i)) = i Next
With Sheet1
With .[c4:c65536].Validation .Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Join(d.keys, \ End With End With End Sub
12，字典+ADO+GetRows设置3级动态数据有效性
‘http://club.excelhome.net/thread-672437-1-1.html Public Arr Sub yy()
Dim mydata$, mytable$, SQL$, cnn
mydata = ThisWorkbook.Path & \数据库.mdb\ mytable = \数据\
Set cnn = CreateObject(\ With cnn
.Provider = \ .Open mydata End With
SQL = \ Arr = cnn.Execute(SQL).GetRows
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 <> 3 And Target.Column <> 1 Then Exit Sub Dim d, i&, Myr&
If Target.Column = 1 Then
Set d = CreateObject(\ For i = 0 To UBound(Arr, 2) d(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) = \ Target.Offset(0, 2) = \ Set d = Nothing
ElseIf Target.Column = 2 And Target.Offset(0, -1) <> \ Set d = CreateObject(\ For i = 0 To UBound(Arr, 2)
If Arr(1, i) = Target.Offset(0, -1).Text Then d(Arr(2, i)) = \ End If Next i
With Target.Validation .Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, Formula1:=Join(d.keys, \ End With
Target.Offset(0, 1) = \ Set d = Nothing