发布时间 : 星期五 文章Excel VBA_多级动态数据有效性设置实例集锦更新完毕开始阅读
1
‘help0209.xls
Dim Myr&, Arr
Private Sub Worksheet_Activate() Dim i&, aa$, k, bb$
Dim d, n&, Sht As Worksheet
Set d = CreateObject(\Myr = Sheet2.[b65536].End(xlUp).Row Arr = Sheet2.Range(\For i = 1 To UBound(Arr) d(Arr(i, 1)) = \Next
k = d.keys
For i = 0 To UBound(k) bb = bb & k(i) & \Next
bb = bb & \遗漏\
With Sheet1.[a5].Validation .Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, Formula1:=bb End With
For Each Sht In Sheets
If InStr(Sht.Name, \月\ aa = aa & Sht.Name & \ End If Next
aa = Left(aa, Len(aa) - 1) With Sheet1.[b5].Validation .Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, Formula1:=aa End With End Sub
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub
If Target.Address <> \
Dim i&, n&, bm$, yf$, r1, Arr1, Arr2, r2, n1% bm = [a5].Value yf = Target.Value [c5:d200] = \If bm <> \遗漏\
Set r1 = Sheet2.[a:a].Find(bm, , , 1) If Not r1 Is Nothing Then n = r1.Row
If Sheet2.Cells(n, 1).MergeArea.Rows.Count > 1 Then n1 = Sheet2.Cells(n, 1).MergeArea.Rows.Count Arr1 = Sheet2.Cells(n, 2).Resize(n1, 1) ReDim Arr2(1 To n1, 1 To 1) [c5].Resize(n1, 1) = Arr1 For i = 1 To n1
Set r2 = Sheets(yf).[a:a].Find(Arr1(i, 1), , , 1) If Not r2 Is Nothing Then
Arr2(i, 1) = Sheets(yf).Cells(r2.Row, 2) End If Next
[d5].Resize(n1, 1) = Arr2 End If End If Else
Dim m&
m = Sheets(yf).[b65536].End(xlUp).Row: n = 4 Arr1 = Sheets(yf).Cells(2, 1).Resize(m - 1, 2) For i = 1 To UBound(Arr1) If Arr1(i, 1) = \ n = n + 1
Cells(n, 4) = Arr1(i, 2) End If Next End If
Sheet1.Activate End Sub
5，多条件一对多查询动态数据有效性 by:山菊花
‘http://club.excelhome.net/viewthread.php?tid=375115&extra=&page=1 ‘山菊花_多条件一对多查询数据有效性代码.xls
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub
If Target.Row < 3 Or Target.Column = 1 Or Target.Column > 5 Then Exit Sub If Target = \Dim nRow%, cTxt$, pm$, nL%
pm = Range(\With Sheets(\数据源\
nRow = .Range(\arr = .Range(\dm = .Range(\
If Target.Column = 5 Then
nL = Sheets(\数据源\End If End With
For i = 1 To nRow - 2
Select Case Target.Column Case 2
If InStr(arr(i, 3), pm) > 0 Then If cTxt = \ cTxt = arr(i, 1) Else
cTxt = \现货,途中\ Exit For End If End If Case 3
If InStr(arr(i, 3), pm) > 0 And arr(i, 1) = Target.Value Then cTxt = cTxt & IIf(cTxt = \ End If Case 4
If InStr(arr(i, 3), pm) > 0 And arr(i, 1) = Target.Offset(, -1).Value And arr(i, 2) = Target.Value Then
For j = 4 To 9
If arr(i, j) <> \
cTxt = cTxt & IIf(cTxt = \ Exit For End If Next End If Case 5
If InStr(arr(i, 3), pm) > 0 And arr(i, 1) = Target.Offset(, -2).Value And arr(i, 2) = Target.Offset(, -1).Value And arr(i, nL) <> \ cTxt = arr(i, nL) Exit For End If End Select Next
If InStr(cTxt, \
With Target.Offset(, 1).Validation .Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:=cTxt End With End If
Target.Offset(, 1) = Split(cTxt & \End Sub
‘http://club.excelhome.net/viewthread.php?tid=300082&extra=&page=1 Private Sub Worksheet_Change(ByVal Target As Range) Dim Rng As Range, nRow%, L%, R%, cTxt$, ds, m Set ds = CreateObject(\定义字典 On Error Resume Next
'Application.EnableEvents = False ’如果不需要自动填充，请删除该行代码前面的注释符号 For Each Rng In Target
L = Rng.Column '当前单元格列号 R = Rng.Row '当前单元格行号 If R >= 12 And L <= 4 Then
If Rng = \当清除单元格数据时 With Rng.Offset(, 1).Resize(1, 5 - L)
.Validation.Delete '删除右向所有单元格的数据有效性 .ClearContents '清除右向所有单元格内容 End With Else
nRow = Sheets(\资料1\资料行数 zl = Sheets(\资料1\把资料保存到数组z1中 For i = 1 To nRow '循环数组各行
If (Range(\(Range(\\
cTxt = zl(i, L + 1)
ds.Add cTxt, m + 1 '把数据增加到字典中 If Err.Number = 0 Then m = m + 1 End If Err.Clear End If Next
cTxt = Join(ds.Keys, \
Rng.Offset(, 1).Validation.Delete '删除数据有效性 If m > 0 Then
With Rng.Offset(, 1).Validation .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop,