A different kind of compare

[jayhouse]

Hello,

I am working on a project that relies on 2 workers individual reviews of the same movie. There is a concern that some of the second reviews are too similar to the first because the second worker is somehow copying the first workers review. I have about 14 thousand entries to audit and i was hoping that there would be an easy way to compare the two fields and return a percentage of similarity based on words or phrases (preferably words) but not the order that they are in.
Since the thought is on the second set of notes are the copy, i would think it would be best to count the number of words in the second set and find how many of them are the same in the first set.


How i think it should display (text colors are only showing the comparison in the example)

Notes 1	Notes 2	Notes 2 similar to Notes 1 (%)
This movie is great	This movie is great	100%
This movie was a jam packed action movie	this was a great action movie	(5 of 6) = 83%
Drama movie was intense with a full filling experience	too long of a movie	(2 of 5) = 40%

<tbody>
</tbody>

4 out of 4 words from the second notes are the same as the first so it would be 100%

5 out of 6 words from the second notes are the same as the first so it would be 83%

2 out of 5 words from the second notes are the same as the first so it would be 40%




I hope this makes sense, please let me know if this is possible or if there is a better alternative.

Thank you for your time.

 

[MrKowz]

Try the following code. This will use Column A as your "Notes 1" column, Column B as your "Notes 2" column, and return the results in column C.

Public Sub CompareReviews()
Dim LR          As Long, _
    i           As Long
    
Dim ary1        As Variant, _
    ary2        As Variant, _
    aryitem     As Variant

Dim aryCompare  As Variant, _
    cntCompare  As Long
    
Application.ScreenUpdating = False
    
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LR
    ary1 = Split(Range("A" & i).Value, " ")
    ary2 = Split(Range("B" & i).Value, " ")
    For Each aryitem In ary2
        aryCompare = Application.Match(aryitem, ary1, 0)
        If Not IsError(aryCompare) Then
            'Value found
            cntCompare = cntCompare + 1
        End If
    Next aryitem
    Range("C" & i).Value = cntCompare / (UBound(ary2) + 1)
    Erase ary1
    Erase ary2
    cntCompare = 0
Next i

Application.ScreenUpdating = True

End Sub

Using your sample data, I got the following results:

Excel 2013/2016
	A	B	C
1	Notes 1	Notes 2	Result
2	This movie is great	This movie is great	100.00%
3	This movie was a jam packed action movie	this was a great action movie	83.33%
4	Drama movie was intense with a full filling experience	too long of a movie	40.00%
Sheet1

 

[jayhouse]

Thank you for responding Mr Kowz, also thank you for writing the macro. I am less than a novice on them but i do know how to implement them.

It does work for the first 7 or so entries but then i am prompted with "Run-time error '6': Overflow".
Selecting Debug takes me to the highlighted portion

Range("C" & i).Value = cntCompare / (UBound(ary2) + 1)

What should i do?

 

[MrKowz]

When the code errors and highlights that line, what values are being returned for cntCompare and UBound(ary2)? You should be able to see this by hovering these words.

 

[jayhouse]

cntCompare = 0
UBound(ary2) = -1

 

[MrKowz]

It came across an entry where there was no second review. Try this adjusted code - this will skip rows where column A or column B is empty.

Public Sub CompareReviews()
Dim LR          As Long, _
    i           As Long
    
Dim ary1        As Variant, _
    ary2        As Variant, _
    aryitem     As Variant

Dim aryCompare  As Variant, _
    cntCompare  As Long
    
Application.ScreenUpdating = False
    
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LR
    If Range("A" & i).Value <> "" And Range("B" & i).Value <> "" Then
        ary1 = Split(Range("A" & i).Value, " ")
        ary2 = Split(Range("B" & i).Value, " ")
        For Each aryitem In ary2
            aryCompare = Application.Match(aryitem, ary1, 0)
            If Not IsError(aryCompare) Then
                'Value found
                cntCompare = cntCompare + 1
            End If
        Next aryitem
        Range("C" & i).Value = cntCompare / (UBound(ary2) + 1)
        Erase ary1
        Erase ary2
        cntCompare = 0
    End If
Next i

Application.ScreenUpdating = True

End Sub

 

[jayhouse]

Nevermind, i found the error. There were some blank entries for the notes.
When i remove these, then the macro works!

Thank you for your time and help!

 

[MrKowz]

Nevermind, i found the error. There were some blank entries for the notes.
When i remove these, then the macro works!

Thank you for your time and help!

Wonderful - thanks for the feedback. Have a good day!