Excel VBS高级编程-关键字查找数据库

这个表格的主要功能是：根据输入的关键字找到数据库中，正确的公司名，生成一个下拉菜单，再根据正确的公司名，找到对应的No生成下拉菜单

欢迎技术交流：wechat:qq-273404452

VBS 代码：

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