Thread: Compare words between two cells and get matching percentage

Hi all,

I have a column with 10,000+ lines, and lots of them are duplicated.
I have a formula that tells me how many times they are duplicated, but it only looks for 100% matching cells.

Now, lots of cells are partially duplicated, for example:

A1 - Team Abcde
A2 - Team Abcde Fghi
B1 - Team Abc

I would like to have a formula giving me a percentage of how two cells are similar to each others by checking the words.
In this case, B1 is 50% similar to A1 because only the word 'Team' is duplicated.
B1 is only 33,34% similar to A2.

I hope any of you can give me a hand on this, thanks :-)

disregard this post...I had a formula here but it didn't work.

I think you need to clarify what happens regards

a) punctuation, eg A and a. are not a match
b) case sensitivity (eg A and a are not a match per se)

and what happens in the case of say a common word with differing frequencies, eg:

A1: my the weather is lovely
B1: my oh my what wonderful weather

In this instance what is the % output ?

Given B seemingly takes precedence in calculating % of the 6 words used in B1 3 are found, however, "my" appears with differing frequency - once in A1 and twice in B1.

The case sensitivity makes this a little more complex I think...

Function CompareString(rngS1 As Range, rngS2 As Range, Optional boolCase As Boolean = True) As Double
Dim vW1, vW2, oDic As Object, lngW As Long, lngU As Long, lngM As Long, strTemp As String 
vW1 = Split(rngS1, " ")
vW2 = Split(rngS2, " ")
Set oDic = CreateObject("Scripting.Dictionary")
For lngW = LBound(vW2) To UBound(vW2) Step 1
    strTemp = Replace(vW2(lngW), ".", "")
    With oDic
        If Not .exists(strTemp) Then
            lngU = lngU + 1
            .Add strTemp, lngU
            If boolCase Then
                lngM = lngM + rngS1.Parent.Evaluate("SUMPRODUCT(--ISNUMBER(FIND("" " & strTemp & " "","" ""&SUBSTITUTE(" & rngS1.Address & ",""."","""")&"" "")))")
            Else
                lngM = lngM - IsNumeric(Application.Match(strTemp,vW1,0))
            End If
        End If
    End With
Next lngW
Set oDic = Nothing
CompareString = lngM / lngU
End Function

the above, stored in a module, could be called from a cell along the lines of:

=COMPARESTRING(A1,B1)

this would generate the results outlined for your examples with the exception of:

Originally Posted by paokun

A1 - A look at the sea.
B1 - Beach look at the a.

Without comparing the words order, out of 5 words, only 4 match, so I'd like to have 80% as a result.

which given stipulated case sensitivity should actually return 60% given a <> A.
The UDF has optional third parameter (Boolean) for Case Sensitivity - default being True - if explicitly set to False in the call you would get the 80%, eg:

=COMPARESTRING(A1,B1,FALSE)

I hope that helps.

Note: in the UDF only a basic punctuation assumption is made (eg period delimiter) - pending complexity of your real strings you will most likely need to elaborate on this part.

Wow, this is fantastic stuff!

Thanks a lot for your quick reply, I really appreciate it.
It works like a charm, and being able to use the 'false' tag is also extremely helpful.

I've got one last question. Would it be possible to compare B1 with a range of cells in A, and show as a result the highest matching percentage?

Edit: .. and show as a result the highest matching percentage and the best matching cell?

For example:
C1 - 86%
D1 - my the weather is lovely (<- text content of the most similar cell)

Edit: Unnecessary.

I'm not quite sure what you're asking for... if you want the UDF to accept multiple strings for comparative purposes then perhaps the below adaptation might help ?

Function CompareString(rngS1 As Range, rngS2 As Range, strType As String, Optional boolCase As Boolean = True) As Variant
Dim vW1, vW2
Dim oDic As Object
Dim lngW As Long, lngU As Long, lngM As Long, lngTemp As Long, rngCell As Range
Dim strTemp As String, strB As String
vW2 = Split(rngS2.Text, " ")
Set oDic = CreateObject("Scripting.Dictionary")
For lngW = LBound(vW2) To UBound(vW2) Step 1
    strTemp = Replace(vW2(lngW), ".", "")
    With oDic
        If Not .exists(strTemp) Then
            lngU = lngU + 1
            .Add strTemp, lngU
        End If
    End With
Next lngW
Set oDic = Nothing
For Each rngCell In rngS1.Cells
    If rngCell.Value <> "" Then
        If rngCell.Value = strTemp Then
            lngM = lngU
            strB = strTemp
        Else
            vW1 = Split(rngCell.Text, " ")
            lngTemp = 0
            For lngW = LBound(vW2) To UBound(vW2) Step 1
                strTemp = vW2(lngW)
                If boolCase Then
                    lngTemp = lngTemp + rngS1.Parent.Evaluate("SUMPRODUCT(--ISNUMBER(FIND("" " & strTemp & " "","" ""&SUBSTITUTE(" & rngCell.Address & ",""."","""")&"" "")))")
                Else
                    lngTemp = lngTemp - IsNumeric(Application.Match(strTemp, vW1, 0))
                End If
            Next lngW
            If lngTemp > lngM Then
                lngM = lngTemp
                strB = rngCell.Text
            End If
        End If
    End If
Next rngCell
Select Case UCase(strType)
    Case "P"
        CompareString = lngM / lngU
    Case "S"
        CompareString = strB
End Select
End Function

the above is now called along the lines of:

C1: =COMPARESTRING($A$1:$A$4,$B$1,"P")

to return the greatest percentage

D1: =COMPARESTRING($A$1:$A$4,$B$1,"S")

to return the associated string

In the case of matching "max" % the first string is returned and as such the above code would stop should an exact match be found - ie it won't iterate through additional cells unnecessarily.

As before you have the optional Boolean as final parameter to denote case sensitivity (default is TRUE - ie Case Sensitive matching)


(edit: and apologies for slight delay in responding - I tend to pop in and out of the forum in the afternoons)

Going forward it would be a lot easier if you posted sample files so we can ensure we're both dealing with the same variations.

Based on your post perhaps:

Function CompareString(rngS1 As Range, rngS2 As Range, strType As String, Optional boolCase As Boolean = True) As Variant
Dim vW1, vW2
Dim oDic As Object
Dim lngW As Long, lngU As Long, lngM As Long, lngTemp As Long, rngCell As Range
Dim strTemp As String, strC As String, strB As String
vW2 = Split(Application.WorksheetFunction.Trim(Replace(Replace(rngS2.Text, ".", ""), Chr(10), " ")), " ")
Set oDic = CreateObject("Scripting.Dictionary")
For lngW = LBound(vW2) To UBound(vW2) Step 1
    strTemp = vW2(lngW)
    With oDic
        If Not .exists(strTemp) Then
            lngU = lngU + 1
            .Add strTemp, lngU
        End If
    End With
Next lngW
Set oDic = Nothing
For Each rngCell In rngS1.Cells
    strC = Application.WorksheetFunction.Trim(Replace(Replace(rngCell.Text, ".", ""), Chr(10), " "))
    If strC <> "" Then
        If strC = rngS2.Text Then
            lngM = lngU
            strB = rngS2.Text
        Else
            vW1 = Split(strC, " ")
            lngTemp = 0
            For lngW = LBound(vW2) To UBound(vW2) Step 1
                strTemp = vW2(lngW)
                If boolCase Then
                    lngTemp = lngTemp + rngS1.Parent.Evaluate("SUMPRODUCT(--ISNUMBER(FIND("" " & strTemp & " "","" " & strC & " "")))")
                Else
                    lngTemp = lngTemp - IsNumeric(Application.Match(strTemp, vW1, 0))
                End If
            Next lngW
            If lngTemp > lngM Then
                lngM = lngTemp
                strB = rngCell.Text
            End If
        End If
    End If
Next rngCell
Select Case UCase(strType)
    Case "P"
        CompareString = lngM / lngU
    Case "S"
        CompareString = strB
End Select
End Function

Note however that regards:

Originally Posted by paokun

It would be best to have it on two lines like A1.

this can only be achieved by altering the word-wrap setting on the cell itself (via Formatting) - once done the result will be per A1 (ie the line break is present it's simply not visible given the cell formatting) ... the UDF can not alter the cell's format.