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

Operator:=xlBetween, Formula1:=cTxt '设置数据有效性 End With

Rng.Offset(, 1).Value = Split(cTxt, \自动填充右一列单元格 Else

Rng.Offset(, 1).Resize(1, 5 - L).ClearContents '清除右边数据 End If

'如果不需要自动填充，则删除上一行代码，并解除注释代码

' Rng.Offset(, 1).ClearContents ’如果不需要自动填充，请删除这段代码前面的注释符号'

' For i = L + 2 To 5 ' With Cells(R, i)

' .Validation.Delete ' .ClearContents ' End With ' Next End If End If Next

'Application.EnableEvents = True’如果不需要自动填充，请删除该行代码前面的注释符号 End Sub

6，在选中Excel单元格时自动展开数据有效性的下拉菜单 by:ningyuanchao小蜜蜂

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

Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column < 3 Then SendKeys \End Sub

7，不同工作簿的数据有效性by:zhaogang1960

‘http://club.excelhome.net/thread-565913-1-1.html ‘装配排产.xls

Dim arr, d As Object

Private Sub Workbook_Open() Dim cnn As Object Dim SQL As String, i&

Set cnn = CreateObject(\

cnn.Open \

Source=\装配产能.xls\请自己修改路径 SQL = \ 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 .[iv:iv] = \

.[iv1].Resize(d.Count) = WorksheetFunction.Transpose(d.Keys) With .[b2:b65536].Validation .Delete

.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=\ End With End With End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) If Sh.Name <> \ If Target.Count > 1 Then Exit Sub

If Intersect(Target, [b2:b65536]) Is Nothing Then Exit Sub If Target = \

If d Is Nothing Then Workbook_Open

Target.Offset(, -1) = arr(0, d(Target.Value)) Target.Offset(, 2) = arr(3, d(Target.Value)) Target.Offset(, 3) = arr(5, d(Target.Value)) End Sub

8，2级动态数据有效性（字典+数组）

‘2013-7-1

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

Dim d, i&, Myr&, Arr, r%, Arr1(), cp$, ks&, js&, j& Set d = CreateObject(\Myr = [h65536].End(xlUp).Row Arr = Range(\ For i = 1 To UBound(Arr) If Arr(i, 1) <> \

d(Arr(i, 1)) = d(Arr(i, 1)) & Arr(i, 2) & \

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