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,
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) & \