Option Explicit

Sub PereborStrok() 'коллекция в словаре
    Dim a, i&, t$, Dic As Object
    Dim el, col, xDiffs As Boolean
    
    xDiffs = (MsgBox("Click Yes to highlight similarities, click No to highlight differences ", vbYesNo + vbQuestion, "Kutools for Excel") = vbNo)
    
    a = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Value
    Set Dic = CreateObject("Scripting.Dictionary")
    With Dic
        .CompareMode = 1
        For i = 1 To UBound(a)
            t = a(i, 1)
            If Len(Trim(t)) Then
            If Not .exists(t) Then .Add t, New Collection
            .Item(t).Add i
            End If
        Next
    End With
    
    For Each el In Dic.keys
    Set col = Dic.Item(el)
        If col.Count > 1 Then
          Call okras(Cells(col(1), 2), Cells(col(2), 2), xDiffs)
        End If
    Next

End Sub


Private Sub okras(xCell1 As Range, xCell2 As Range, xDiffs)
Dim xLen As Long, J As Long
    xCell2.Font.ColorIndex = xlAutomatic
        If xCell1.Value2 = xCell2.Value2 Then
            If Not xDiffs Then xCell2.Font.Color = vbRed
        Else
            xLen = Len(xCell1.Value2)
            For J = 1 To xLen
                If Not xCell1.Characters(J, 1).Text = xCell2.Characters(J, 1).Text Then Exit For
            Next J
            If Not xDiffs Then
                If J <= Len(xCell2.Value2) And J > 1 Then
                    xCell2.Characters(1, J - 1).Font.Color = vbRed
                End If
            Else
                If J <= Len(xCell2.Value2) Then
                    xCell2.Characters(J, Len(xCell2.Value2) - J + 1).Font.Color = vbRed
                End If
            End If
        End If
End Sub