0

I want to extract similar strings within two cells as an Excel function. See below example:

enter image description here

I read some pages like it but doesn't help me.

1
  • What have you tried so far?
    – dmb
    Sep 4, 2021 at 0:23

1 Answer 1

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.

2
  • 1
    Thanks...it's great! I made some edits to fix errors. Since ArrSel() is an array from Range, it starting from 1 rather than 0. So For Loops must be started from LBound(...)+1 .
    – AliM67
    Sep 4, 2021 at 16:07
  • Ah, I forgot to copy the Option Base 1 at the top of the page! it works as is with that option in place, sorry. Sep 4, 2021 at 16:39

You must log in to answer this question.

Not the answer you're looking for? Browse other questions tagged .