发布时间 : 星期一 文章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