[求助]想做一个关键字筛选行

excel_fjl

想利用表2中的 A2单元格 输入关键字，点击按钮。筛选出表1 合作方 这一列中包含关键字的行，输出到表2的A4以后。筛选的时候只要同时包含词中的所有字就筛选出来，比如“萨尔”，“尔萨”，“萨公”，都能筛选出 北京萨尔公司。有没有大神能帮帮忙？？


     


[url=]excel筛选求教.zip[/url]

任飘渺

萨公搞不定
Sub dasd()
Dim arr, brr()

k = "*" & Sheet2.Range("a2").Value & "*"
arr = Sheet1.[a1].CurrentRegion
n = 2
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
For i = 2 To UBound(arr)
    If arr(i, 3) Like k Then
        For j = 1 To UBound(arr, 2)
            brr(n, j) = arr(i, j)
        Next j
        n = n + 1
    End If
Next i
Sheet2.Range("a6:D1000").Clear

Sheet2.Range("a6").Resize(n, UBound(brr, 2)) = brr
End Sub

excel_fjl

任飘渺 发表于 2018-8-7 11:20
萨公搞不定
Sub dasd()
Dim arr, brr()

谢谢你~~~

如果要识别‘萨公’，‘尔萨’ ，我想的是把文字拆成一个一个字作多次筛选，不知道用什么命令实现？

iwangyi

Sub 模糊查找()
Set cn = CreateObject("ADODB.CONNECTION")
cn.Open "PROVIDER=MICROSOFT.JET.oledb.4.0;EXTENDED PROPERTIES=EXCEL 8.0;DATA SOURCE=" & ThisWorkbook.FullName
hzf = Cells(2, 1)
Sql = "SELECT * from [sheet1$a1:d] where 合作方 like '" & "%" & hzf & "%" & "'"
Sheet1.Rows(1).Copy [a3]
Range("A4").CopyFromRecordset cn.Execute(Sql)
End Sub

iwangyi

附件************

excel_fjl

iwangyi 发表于 2018-8-7 13:10
附件************

非常感谢~~

不过还是没有解决 ‘尔萨’，‘萨公’搜索 这样的问题~

xiangbaoan

excel_fjl 发表于 2018-8-7 14:04
非常感谢~~

不过还是没有解决 ‘尔萨’，‘萨公’搜索 这样的问题~

………………仅供参考………………

excel_fjl

太感谢啦~~~~~完美解决问题

就是输入为空的时候下标越界了，我看看怎么改

excel_fjl

xiangbaoan 发表于 2018-8-7 14:17
………………仅供参考………………

太感谢啦~~~~~完美解决问题

就是输入为空的时候下标越界了，我看看怎么改

xiangbaoan

excel_fjl 发表于 2018-8-7 15:32
太感谢啦~~~~~完美解决问题

就是输入为空的时候下标越界了，我看看怎么改

Sub test()
Dim st$, ar, br(), k&, r&, c%, i%, b%, t()
st = Replace(Sheet2.[a2], " ", "")
If Len(st) = 0 Then Exit Sub '在这里加个判断不就行了?
For i = 1 To Len(st)
    ReDim Preserve t(1 To i)
    t(i) = Mid(st, i, 1)
Next
k = 1
ar = Sheet1.[a1].CurrentRegion.Resize(, 4)
ReDim Preserve br(1 To 4, 1 To k)
For i = 1 To 4
    br(i, k) = ar(1, i)
Next
For r = 2 To UBound(ar)
    b = 1
    st = ar(r, 3)
    For i = 1 To UBound(t)
        b = b * InStr(st, t(i))
    Next
    If b Then
        k = k + 1
        ReDim Preserve br(1 To 4, 1 To k)
        For c = 1 To UBound(ar, 2)
            br(c, k) = ar(r, c)
        Next
    End If
Next
If k - 1 Then
    With Sheet2
        .[a3].Resize(.Rows.Count - 2, 4) = ""
        .[a3].Resize(k, UBound(br)) = Application.WorksheetFunction.Transpose(br)
    End With
End If
End Sub