Finding similar strings within two cells in excel
Solution 1:
You can try this code:
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
Change the value of ChkLen to be the minimum match you are looking for, highlight the two columns to be compared and the result should be placed in the next column (eg, if you select range A2:B10 the results will appear in C2:C10. If you want to change the offset of the result column
paste in a module and link to a button or otherwise run the code from the VBA editor.