求助：模糊查找匹配

00胖九00

工作中遇到一个需要手动粘贴的工作，因为数据量太大了，所以想考虑自动化，感觉用公式好像无法实现，求助vba大神指点，详见附件。
非常感谢~

loirol

继续复制粘贴吧，完全不知所云

ykcbf1100

请楼主补充说明，怎么个模糊法。

shiruiqiang

个人猜测应该是同时满足2个条件 instr吧

3190496160

Sub 模糊查询()
Dim ar As Variant, br As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("库")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "库为空！": End
    ar = .Range("a1:f" & r)
End With
With Sheets("sheet1")
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "查询表为空！": End
    .Range("c2:e" & rs) = Empty
    br = .Range("a1:e" & rs)
    For i = 2 To UBound(br)
        d.RemoveAll
        If Trim(ar(i, 1)) <> "" And Trim(ar(i, 2)) <> "" Then
            rr = Split(br(i, 2), ",")
            For s = 0 To UBound(rr)
                If rr(s) <> "" Then
                    d(rr(s)) = ""
                End If
            Next s
            sl = UBound(rr) + 1
            For s = 2 To UBound(ar)
                gs = 0: m = 0
                If InStr(ar(s, 2), br(i, 1)) > 0 Then
                    rr_1 = Split(ar(s, 4), ",")
                    For ss = 0 To UBound(rr_1)
                        If rr_1(ss) <> "" Then
                            If d.exists(rr_1(ss)) Then
                                gs = gs + 1
                            End If
                        End If
                    Next ss
                    If gs = sl Then m = m + 1: xh = s: Exit For
                End If
            Next s
            If m > 0 Then
                br(i, 3) = ar(xh, 5)
                br(i, 4) = ar(xh, 3)
                br(i, 5) = ar(xh, 6)
            Else
                br(i, 3) = "无"
            End If
        End If
    Next i
    .Range("a1:e" & rs) = br
End With
MsgBox "ok!"
End Sub

3190496160

模糊查找匹配.rar (19.76 KB, 下载次数: 14)

2024-11-7 09:23 上传

点击文件名下载附件

3190496160

数据源模拟数据太少，不知道数据是按什么顺序来排列的，代码仅供参考，实在不行，可以加v