关注公众号:万能的Excel 并回复【关键字】获取源文件!
功能说明:
这个表格的主要功能是:根据输入的关键字找到数据库中,正确的公司名,生成一个下拉菜单,再根据正确的公司名,找到对应的No生成下拉菜单
本工作薄实现的功能:
1、根据关键字模糊查找
2、自动讲搜索内容生成下拉菜单
3、在选中后自动提取出ID信息
附件代码:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim whereStr$, sql$, conn, mr&, j%, k%, l%, n&, z
Dim i, m, com, x As Long, w1 As String
Dim arr, t As Long
Dim d1, d2 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
j = Target.Row
On Error Resume Next
'根据关键字搜索匹配数据,写入到Sheet3
If Target.Count = 1 And Not Intersect(Range("k2:L65536"), Target) Is Nothing Then
whereStr = whereStr & IIf(Cells(j, 12) = "", "", " and [No] like '%" & Cells(j, 12) & "%'")
whereStr = whereStr & IIf(Cells(j, 11) = "", "", " and [company] like '%" & Cells(j, 11) & "%'")
mr = Sheet3.Cells(Rows.Count, 1).End(xlUp).Row
If mr > 2 Then Sheet3.Range("A1:G" & mr).Clear
If whereStr <> "" Then
Set conn = CreateObject("ADODB.connection")
conn.Open "Provider=Microsoft.Ace.oledb.12.0;extended properties='excel 12.0;HDR=yes';data source=" & ThisWorkbook.FullName
sql = "select * from [元数据$D1:F] where" & Mid(whereStr, 5)
[Sheet3!A1].CopyFromRecordset conn.Execute(sql)
conn.Close
Set conn = Nothing
End If
End If
'根据sheet3中的数据,生成数据字典
com = Sheet3.Range("b2").CurrentRegion
For m = 2 To UBound(com)
If d1(com(m, 2)) = "" Then
d1(com(m, 2)) = com(m, 3)
d2(com(m, 2)) = com(m, 1)
Else
d1(com(m, 2)) = d1(com(m, 2)) & "," & com(m, 3)
End If
Next m
'生成下拉菜单
With Target.Validation
If Not Intersect(Target, [J2:J65536]) Is Nothing Then '触发公司名单元格生成下拉菜单
.Delete
If Not Target.Value <> "" Then
.Add Type:=xlValidateList, Formula1:=Join(d1.keys, ",")
End If
Target.Offset(, -1).Value = d2(Target.Value)
ElseIf Not Intersect(Target, [h2:h65536]) Is Nothing And Target.Offset(, 2) <> "" Then '触发No单元生成下拉菜单
.Delete
If Not Target.Value <> "" Then
.Add Type:=xlValidateList, Formula1:=d1(Target.Offset(, 2).Value)
End If
End If
End With
Dic.RemoveAll
End Sub