Letter by letter Comparison

Question

I have 2 sets of data in two cells (A1 and B1) without any special character (.,/;:'"-@#$%^&*(){}[]) and also no space between words,

The problem is I need to compare both the cells and identify and highlight the difference.

For example :

(A1): howtobuilfmacroincludingthesecrria
(B1): howbuilfmacroincludingthesecriteria

• in A1 ite is missing
• and B1 to is missing

The macro should highlight ite in B1 and to in A1

Answer 1

Make sure the text strings are in cells A1 and B1.

Place these routines in a standard code module (Alt-F11).

Run the FindDistinctSubstrings routine (Alt-F8 from the worksheet).

Public Sub FindDistinctSubstrings()
    Dim a$, b$
    a = [a1]
    b = [b1]
    S1inS2 0, 2, a, b, [a1], vbRed
    S1inS2 0, 2, b, a, [b1], vbRed
    S1inS2 1, 3, a, b, [a1], vbBlack
    S1inS2 1, 3, b, a, [b1], vbBlack
End Sub
Private Sub S1inS2(yes&, k&, s1$, s2$, r As Range, color&)
    Dim i&
    For i = 1 To Len(s1)
        If (yes = 0 And 0 = InStr(s2, Mid$(s1, i, k))) Or (yes = 1 And 0 < InStr(s2, Mid$(s1, i, k))) Then
            r.Characters(i, k).Font.color = color
        End If
    Next
End Sub

Answer 2

it's very difficult to perform mutual checks because excel doesn't know the words. What does it words represent? You can do check on one column like this:

Sub CompareMacro()
Dim columnA As Integer
Dim columnB As Integer
Dim NumberOfCaracters As Integer
Dim f As Integer
f = 1
For numbuerOfRows = 1 To 5
    columnA = Len(Worksheets(1).Cells(numbuerOfRows, 1))
    columnB = Len(Worksheets(1).Cells(numbuerOfRows, 2))

    If columnA > columnB Then
        NumberOfCharacters = columnA
    Else
        NumberOfCaracters = columnB
    End If

    Dim columnALetters(3) As Variant

    For i = 1 To NumberOfCaracters

        If Mid(Worksheets(1).Cells(numbuerOfRows, 1), i, 1) = Mid(Worksheets(1).Cells(numbuerOfRows, 2), f, 1) Then                 
             f = f + 1
         Else
    Worksheets(1).Cells(numbuerOfRows, 1).Characters(i, 1).Font.Color = vbRed
        End If      
    Next i
Next numbuerOfRows
End Sub