I'm trying to compare two sentences in different cells and show the difference in red.

My code is comparing the position of each letter. When it finds a difference it shows it in red which is fine.

The problem is that if a word is changed with a word with a different amount of letters, the rest of the sentence also appears in red.

As an example:

In this picture you can see that after a word is found, the rest of the words also appear as different even though they are the same.

This is the code that I'm currently using:

Sub Compare()

For i = 1 To Len(ActiveSheet.Range("F1").Value)

If (ActiveSheet.Range("F1").Characters(i, 1).Text <> ActiveSheet.Range("G1").Characters(i, 1).Text) Then

    ActiveSheet.Range("F1").Characters(i, 1).Font.Color = RGB(255, 0, 0)
    
End If

Next i

End Sub

Also, this code is only working on the selected cell. How can I make it work with the entire column (F and G)?

CodePudding user response：

Compare Words in Two Cells

• Hardly tested.

Option Explicit

Sub CompareTwoCellsTEST()
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    CompareTwoCells ws.Range("A1"), ws.Range("B1")
End Sub

Sub CompareTwoCells(ByVal ChangeCell As Range, ByVal CompareCell As Range)
    
    Dim Change() As String: Change = Split(CStr(ChangeCell.Value))
    Dim Compare() As String: Compare = Split(CStr(CompareCell.Value))
    
    Dim n As Long
    Dim Pos As Long
    Dim ch As Long
    Dim ErrNum As Long
    Dim sChange As String
    Dim sCompare As String
    
    For n = 0 To UBound(Change)
        sChange = Change(n)
        On Error Resume Next
            sCompare = Compare(n)
        On Error GoTo 0
        If Len(sCompare) > 0 Then
            If StrComp(sChange, sCompare, vbBinaryCompare) <> 0 Then
                For ch = 1 To Len(sChange)
                    If ErrNum = 0 Then
                        On Error Resume Next
                            If Mid(sChange, ch, 1) <> Mid(sCompare, ch, 1) Then
                                ChangeCell.Characters(Pos   ch, 1) _
                                    .Font.Color = vbRed
                            End If
                           ErrNum = Err.Number
                        On Error GoTo 0
                    Else
                        ChangeCell.Characters(Pos   ch, 1).Font.Color = vbRed
                    End If
                Next ch
                ErrNum = 0
            End If
            sCompare = vbNullString
        End If
        Pos = Pos   Len(sChange)   1
    Next n

End Sub

CodePudding user response：

As suggested in the comments, Split function here is your friend:

Anyways, this will work properly only if both phrases got same quantity of words and in the same expected order. Totally diferent phrases may produce weird results.