跪求把这个修改成可以模糊搜索的！！

心湖的石子

在本坛里找了个文件。可以不能模糊查询。麻烦好心人帮忙修改一下。
Sub 查询()
'引用Microsoft ActiveX Data Objects 2.x Library
    Dim cnn As New ADODB.Connection
    Dim SQL$, arr, i&, s$
    arr = Range("D1").CurrentRegion
    If Not IsArray(arr) Then Exit Sub
    If UBound(arr) = 1 Then Exit Sub
    If Len(arr(2, 1)) Then s = s & " and " & arr(1, 1) & "=" & arr(2, 1)
    For i = 2 To UBound(arr, 2)
        If Len(arr(2, i)) Then s = s & " and " & arr(1, i) & "='" & arr(2, i) & "'"
    Next
    SQL = "select * from 账户资料 where" & Mid(s, 5)
    cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\查询修改ac.accdb"
    Range("D6:O" & Rows.Count).ClearContents
    Range("d6").CopyFromRecordset cnn.Execute(SQL)
    cnn.Close
    Set cnn = Nothing
End Sub

ly

没有调试，不知变量s为何物，基本靠闷了。
SQL = "select * from 账户资料 where [字段名] Like * " & Mid(s, 5) & “*”

心湖的石子

ly 发表于 2018-9-28 18:47
没有调试，不知变量s为何物，基本靠闷了。
SQL = "select * from 账户资料 where [字段名] Like * " & Mi ...

您好，我把文件上次，麻烦给改改。

没事吃个苹果

Sub 查询()
'引用Microsoft ActiveX Data Objects 2.x Library
    Dim cnn As New ADODB.Connection
    Dim SQL$, arr, i&, s$
    arr = Range("D1").CurrentRegion
    If Not IsArray(arr) Then Exit Sub
    If UBound(arr) = 1 Then Exit Sub
    If Len(arr(2, 1)) Then s = s & " and " & arr(1, 1) & "=" & arr(2, 1)
    For i = 2 To UBound(arr, 2)
        If Len(arr(2, i)) Then s = s & " and " & arr(1, i) & " like '%" & arr(2, i) & "%'"
    Next
    SQL = "select * from 账户资料 where" & Mid(s, 5)
    cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\查询修改ac.accdb"
    Range("D6:O" & Rows.Count).ClearContents
    Range("d6").CopyFromRecordset cnn.Execute(SQL)
    cnn.Close
    Set cnn = Nothing
End Sub

心湖的石子

太感谢二位的热心了，可以用了。世界有你们这样的人更美好！！！