Compare two columns and highlight the differences

[hatch]

I have two excel columns side by side "original" and "edited". In a separate column I want to compare the edited column with the original column, with new text coloured green and removed text coloured red and stuck through

For example:

Original	Edited	Comparison
The cow jumped over the moon	The dog jumped over the moon	The <strike><strike>cow </strike>dog </strike>jumped over the moon

<tbody>
</tbody>

I found this thread which helped me on my way but I’m not great with VBA so now I’m stuck

http://www.mrexcel.com/forum/excel-...pare-two-strings-highlight-differences-2.html

Any help would be much appreciated

 

[onlyadrafter]

Hello,

This code is really clunky, and definitely can be made more concise. Seems to work though (on the three examples I used).
It does assume that an amended word is replaced by another word.

Sheet 2 will need to be empty.

Sub CHECK_DIFFERENCES()
    Application.ScreenUpdating = False
    With Sheets("Sheet1")
        For MY_ROWS = 1 To .Range("A" & Rows.Count).End(xlUp).Row
            Sheets("Sheet2").Range("A1").Value = .Range("A" & MY_ROWS).Value
            Sheets("Sheet2").Range("A2").Value = .Range("B" & MY_ROWS).Value
        With Sheets("Sheet2")
        .Range("A1:A2").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
            Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
            :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1))
            For MY_COLS = 1 To .Cells(1, Columns.Count).End(xlToLeft).Column
                If .Cells(1, MY_COLS).Value = .Cells(2, MY_COLS).Value Then
                    .Cells(3, MY_COLS).Value = .Cells(2, MY_COLS).Value
                Else
                    .Cells(3, MY_COLS).Value = .Cells(1, MY_COLS).Value
                    .Cells(4, MY_COLS).Value = .Cells(2, MY_COLS).Value
                    .Cells(3, MY_COLS).Font.ColorIndex = 3
                    .Cells(4, MY_COLS).Font.ColorIndex = 10
                End If
            Next MY_COLS
            For MY_NEW_COLS = 1 To .Cells(3, Columns.Count).End(xlToLeft).Column
                If IsEmpty(.Cells(4, MY_NEW_COLS).Value) Then
                    If MY_TEXT <> "" Then
                        MY_TEXT = MY_TEXT & " " & .Cells(3, MY_NEW_COLS).Value
                    Else
                        MY_TEXT = .Cells(3, MY_NEW_COLS).Value
                    End If
                Else
                    If MY_TEXT <> "" Then
                        MY_TEXT = MY_TEXT & " " & .Cells(3, MY_NEW_COLS).Value
                        MY_TEXT = MY_TEXT & " " & .Cells(4, MY_NEW_COLS).Value
                    Else
                        MY_TEXT = MY_TEXT & .Cells(3, MY_NEW_COLS).Value
                        MY_TEXT = MY_TEXT & " " & .Cells(4, MY_NEW_COLS).Value
                    End If
                End If
            Next MY_NEW_COLS
            .Cells(5, 1).Value = MY_TEXT
            Sheets("Sheet2").Select
            MY_LEN = 1
            For FORMAT_COLS = 1 To .Cells(3, Columns.Count).End(xlToLeft).Column
                MY_STR = Len(Cells(3, FORMAT_COLS).Value)
                If .Cells(3, FORMAT_COLS).Font.ColorIndex = 3 Then
                    With Cells(5, 1)
                        With .Characters(Start:=MY_LEN, Length:=MY_STR).Font
                            .Strikethrough = True
                            .ColorIndex = 3
                        End With
                        MY_NEXT_LEN = Len(Cells(4, FORMAT_COLS).Value)
                        With .Characters(Start:=MY_LEN + MY_STR + 1, Length:=MY_NEXT_LEN).Font
                            .Strikethrough = True
                            .ColorIndex = 10
                        End With
                        MY_EXTRA_COUNT = MY_EXTRA_COUNT + 1
                    End With
                End If
                MY_LEN = MY_LEN + Len(Cells(3, FORMAT_COLS).Value) + 1 + Len(Cells(4, FORMAT_COLS).Value)
                If Not IsEmpty(.Cells(4, FORMAT_COLS)) Then
                    MY_LEN = MY_LEN + 1
                    MY_EXTRA_COUNT = MY_EXTRA_COUNT + 1
                End If
            Next FORMAT_COLS
            Sheets("Sheet2").Range("A5").Copy
            Sheets("Sheet1").Range("C" & MY_ROWS).PasteSpecial (xlPasteValues)
            Sheets("Sheet1").Range("C" & MY_ROWS).PasteSpecial (xlPasteAll)
        End With
     Sheets("Sheet2").Rows("1:5").Delete
     MY_TEXT = ""
     MY_EXTRA_COUNT = 0
     Next MY_ROWS
    End With
    Sheets("Sheet1").Select
    Application.ScreenUpdating = True
End Sub

did say it was clunky.