VBA中怎么根据多个关键字来实现模糊查找功能

zzgezi

各位老师好。

我现在想用VBA来实现一个功能；就是根据几个关键字，实现查找到数据库里对应的详细数据；例如：

我想根据“1.5K”和“0603”这两个关键字找到数据库中对应的“国巨，1.5KΩ ±1﹪， 1/10W  0603”



我上网查到模糊查找功能可以用“instr”函数，但是“instr”函数只能放一个比较字符串，不能比较多个。

老师们，我需要怎么实现呢？谢谢了。
BOM制作2.zip (32.03 KB, 下载次数: 52)

2019-10-16 08:57 上传

点击文件名下载附件

zpy2

正则也可以的，可以把所有字段组合成一个字段再查询

zzgezi

zpy2 发表于 2019-10-16 09:13
正则也可以的，可以把所有字段组合成一个字段再查询

谢谢，
合并之后，形成“1.5K0603”，但是和“国巨，1.5KΩ ±1﹪， 1/10W  0603”没有相同的字符串。应该查找不到吧？

老师方便写下代码吗？

aman1516

多关键字，
If InStr(Str, key1) And InStr(Str, key2) Then
建议还是规范下数据库的项目吧：尽量将“料件规格”的子项属性分成不同数据列，更方便全方位的查询、筛选及全表模糊快速搜索等操作

zpy2

zzgezi 发表于 2019-10-16 09:31
谢谢，
合并之后，形成“1.5K0603”，但是和“国巨，1.5KΩ ±1﹪， 1/10W  0603”没有相同的字符串。应 ...

1.5K.*0603
中间用通配符连接
VBA like 也可以，我是用的正则匹配的

ningjizaikuangy

用vloolup（）函数模糊匹配，，vloopup（"*"&"1.5K"&"*"&"0603"&*",数据库，第几列，0），多个关键字同理，，关键字 也可以用单元格代替

likaiyihou

不会用正则，用数组循环查找实现多个关键词的查找。供参考。
Sub myfind()
    With Sheets("数据库")
        lastrow = .Range("c" & Rows.Count).End(xlUp).Row
        mydata = .Range("c3:c" & lastrow)
        
        inputkey = CStr(InputBox("请输入要查找的关键词，多个关键词以英文逗号隔开", "Enter Data"))
        If inputkey = "" Then Exit Sub
        mykeys = Split(inputkey, ",")
        
        Set d_key = CreateObject("scripting.dictionary")
        For i = LBound(mykeys) To UBound(mykeys)
            If mykeys(i) <> "" Then d_key(mykeys(i)) = ""
        Next
        count_key = d_key.Count
        mykey = d_key.keys
        Set d_key = Nothing
        
        Set d_data = CreateObject("scripting.dictionary")
        For i = LBound(mydata) To UBound(mydata)
            If mydata(i, 1) <> "" Then d_data(mydata(i, 1)) = ""
        Next
        count_data = d_data.Count
        mydatas = d_data.keys
        Set d_data = Nothing
        
        ReDim arr(1 To count_data)
        
        For j = 1 To count_data
            p = 1
            For i = 1 To count_key
                If InStr(mydatas(j - 1), mykey(i - 1)) = 0 Then
                    p = 0
                    Exit For
                End If
            Next
            If p = 1 Then
                t = t + 1
                arr(t) = mydatas(j - 1)
            End If
        Next
        If t = 0 Then Exit Sub
        
        Set d_result = CreateObject("scripting.dictionary")
        For i = 1 To t
             d_result(arr(i)) = ""
        Next
        count_result = d_result.Count
        arr_result = Application.Transpose(d_result.keys)
        Set d_result = Nothing
        
        .Range("f3").Resize(lastrow - 2, 1).ClearContents
        .Range("f3").Resize(count_result, 1) = arr_result
        
    End With
End Sub

likaiyihou

有点缺陷，.Range("f3").Resize(lastrow - 2, 1).ClearContents这句应该放最前面，请自行修改。