答案1
你可以尝试这个代码:
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 编辑器运行代码。