根据字符串名称进行模糊匹配

cmo9020

请教各位导师根据字符串名称进行模糊匹配，求助
TEST主控文档
执行后
1.C列与  目标A.xlsx  B列 行对应
2.H列与目标D列是要进行字符串模糊比对 只要字符串内容有部份相同即可
3.上面2項都匹配才會将目标C列内容填入到当前D列(反橘色部份)

举例:
H列"port:擦边" 和目标D列 "AK-port-优-JR-侧边"字符串内容都有"port"这样就可以

现在代码只有做到C列与目标B列做比对...
模糊比对部份不会,请导师们出手帮助一下~谢谢

Test.7z (24.93 KB, 下载次数: 3)

2024-5-12 13:32 上传

点击文件名下载附件

Sub Update333()
    Dim wb As Workbook, dic As Object
    Dim i As Integer, j As Long
    Dim arr, s
    Dim Target As Range
    Dim cell As Range

    Set Target = Range("C1:C" & Cells(Rows.Count, 1).End(xlUp).Row)

    Dim filePath As String

    filePath = ThisWorkbook.Path & "\A.xlsx"

    Set wb = Workbooks.Open(filePath)
    Set dic = CreateObject("Scripting.Dictionary")
   
    j = wb.Worksheets("Sheet1").Range("B65536").End(xlUp).Row
    With wb.Worksheets("Sheet1")
        arr = .Range("A1:G" & j)
        For i = 2 To j
            dic(.Cells(i, 2).Value) = .Cells(i, 2).Value & "|" & .Cells(i, 3).Value
        Next
    End With

    For Each cell In Target
        If cell.Value <> "" Then
            If dic.Exists(cell.Value) Then
                s = Split(dic(cell.Value), "|")
                If cell.Offset(0, 2) = "" Then
                    cell.Offset(0, 1) = s(1)
                End If

            End If
        End If
    Next cell
   
    wb.Close SaveChanges:=False
    Set wb = Nothing
    Set dic = Nothing
   
End Sub

shiruiqiang

你要模糊匹配多少的字？理论代码

Qs18

Public Sub test()
Application.ScreenUpdating = False
Dim arr, wb As Workbook, wb2 As Workbook, r As Range, rng As Range
Set wb = ThisWorkbook
Set rng = Range("c2:c" & Cells(Rows.Count, "c").End(xlUp).Row)
Set wb2 = Workbooks.Open(ThisWorkbook.Path & "\A.xlsx")
arr = ActiveWorkbook.Worksheets(1).Range("a1").CurrentRegion.Value
wb2.Close (False)
For Each r In rng
    For i = 2 To UBound(arr)
        If arr(i, 2) = r.Value And arr(i, 4) Like "*" & r.Offset(0, 5).Value & "*" Then
            r.Offset(0, 1) = arr(i, 3)
        End If
    Next i
Next
Application.ScreenUpdating = True
End Sub