Compare two cells and show the changes in another cell

user_17542634 0
Viewed 49

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:

enter image description here

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)?

compare vba excel
3 Answers

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
user_98140690

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

Split function

try this code:

Sub test()
Dim ControlActual As Variant
Dim ControlAntiguo As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim AcumuladoControlActual As Long
Dim AcumuladoControlAntiguo As Long


i = 4 'starting row of data

Do Until Range("A" & i).Value = ""
    ControlActual = Split(Range("A" & i).Value, " ")
    ControlAntiguo = Split(Range("B" & i).Value, " ")
    AcumuladoControlActual = 0
    AcumuladoControlAntiguo = 0
    
    For j = LBound(ControlActual) To UBound(ControlActual) Step 1
        k = 1
        Do Until k > Len(ControlActual(j)) And k > Len(ControlAntiguo(j))
            If Mid(ControlActual(j), k, 1) <> Mid(ControlAntiguo(j), k, 1) Then
                If k <= Len(ControlActual(j)) Then Range("A" & i).Characters(AcumuladoControlActual + k, 1).Font.Color = RGB(255, 0, 0)
                If k <= Len(ControlAntiguo(j)) Then Range("B" & i).Characters(AcumuladoControlAntiguo + k, 1).Font.Color = RGB(255, 0, 0)
            End If
            k = k + 1
        Loop
        
        AcumuladoControlActual = AcumuladoControlActual + Len(ControlActual(j)) + 1
        AcumuladoControlAntiguo = AcumuladoControlAntiguo + Len(ControlAntiguo(j)) + 1
    Next j
    i = i + 1
Loop

End Sub

enter image description here

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.

user_91998280

This code more or less does the trick. It shows where the words are the same by chaining its color to green. This way you can differentiate between the words that are the same (color green) and the ones that are different (standard color).

Hope this helps anyone that had the same problem as mine.

Sub find_differences()

Dim xStr() As String
Dim i As Long
Dim x As Long, y As Long

With ActiveSheet
For i = 3 To .Cells(.Rows.Count, "G").End(xlUp).Row
xStr = Split(.Cells(i, "G").Value, " ")
xStrH = Split(.Cells(i, "H").Value, " ")


With .Cells(i, "H")
.Font.ColorIndex = 1

For x = LBound(xStr()) To UBound(xStr())
For y = 1 To Len(.Text)


If Mid(.Text, y, Len(xStr(x))) = xStr(x) Then

.Characters(y, Len(xStr(x))).Font.ColorIndex = 4


End If
Next y
Next x
End With
Next i
End With

 End Sub
user_175426340
Related