在excel中的两个单元格中查找相似的字符串

你可以试试这段代码：

Option Base 1
    Sub CompareStrings2()
        Application.ScreenUpdating = False
        If Selection.Columns.Count <> 2 Then GoTo MyExitSub
        Dim i As Long, lenC1 As Long, lenC2 As Long, r As Long, y As Long, x As Long, ChkLen As Long, OffSetCol As Long
        Dim C1Str As String, C2Str As String, tempStr As String
        Dim ArrC1(), ArrC2, ArrSel, ArrResult
        ArrSel = Selection
        i = UBound(ArrSel, 1)
        ReDim ArrResult(i)
        ReDim ArrC1(i)
        ReDim ArrC2(i)
        For r = LBound(ArrC1, 1) To UBound(ArrC1, 1)
            ArrC1(r) = ArrSel(r, 1)
            ArrC2(r) = ArrSel(r, 2)
        Next r
        ChkLen = 3 ' change this number to be the minimum recognised length, i.e. 1 for a single letter.
            If Len(C1Str) > Len(C2Str) Then
            tempStr = C2Str
            C2Str = C1Str
            C1Str = tempStr
            End If
        For r = LBound(ArrC1, 1) To UBound(ArrC1, 1)
            C1Str = ArrC1(r)
            lenC1 = Len(C1Str)
            C2Str = ArrC2(r)
            lenC2 = Len(C2Str)
            For x = Len(C1Str) To ChkLen Step -1
                For y = 1 To Len(C1Str) - ChkLen
                If InStr(C2Str, Trim(Mid(C1Str, y, x))) Then
                    ArrResult(r) = Trim(Mid(C1Str, y, x))
                    GoTo MyNxtr
                End If
                Next y
            Next x
    MyNxtr:
        OffSetCol = 2 ' Change this value to change the offset column.
        Next r
        For i = LBound(ArrResult) To UBound(ArrResult)
        Selection.Cells(1, 1).Offset(i - 1, OffSetCol) = Trim(ArrResult(i))
        Next i
    MyExitSub:
    Application.ScreenUpdating = True
    End Sub

将 ChkLen 的值更改为您要查找的最小匹配，突出显示要比较的两列，结果应放在下一列中（例如，如果您选择范围 A2:B10，结果将显示在 C2:C10 . 如果要改变结果列的偏移量

粘贴到模块中并链接到按钮或从 VBA 编辑器运行代码。