Compare two strings and highlight the different words

[arvindmotha]

Someone please help with VBA code to find difference between 2 strings and highlight the exact words in a separate cell along with the original text. Should work well even for relatively large text fields like 500-1000 words.

A1 = The quick brown fox jumps over the lazy dog
B1 =The quick brown fox over the lazy dog

C1 should return = The quick brown fox jumps over the lazy dog

Thanks in advance!

 

[HenkDePoema]

Are missing words the only kind of difference between the strings?

 

[arvindmotha]

Are missing words the only kind of difference between the strings?

yes could be missing a set of words or numbers

 

[HenkDePoema]

You could try if this works well enough:

Sub HighlightMissing()

Dim OriginalText() As String
Dim TestText() As String
Dim MissingWords() As String

OriginalText = Split(Range("A1").Value, " ")
TestText = Split(Range("B1").Value, " ")

If UBound(OriginalText) - UBound(TestText) < 0 Then
    MsgBox "Put the longer text in the first cell"
    Exit Sub
End If

ReDim MissingWords(UBound(OriginalText))

j = 0
k = 0
For i = 0 To UBound(OriginalText)
    If OriginalText(i) <> TestText(j) Then
        MissingWords(k) = OriginalText(i)
        k = k + 1 'to add the next missing word
        j = j - 1 'to skip the missing word in TestText in the next iteration
    End If
    If j < UBound(TestText) Then
        j = j + 1
    End If
Next i

If k = 0 Then
    MsgBox "No missing words were found."
    Exit Sub
End If

Range("C1").Value = Range("A1").Value
For Each Word In MissingWords
    If Word <> "" Then
        Range("C1").Characters(InStr(Range("C1").Value, Word), Len(Word)).Font.Color = vbRed
    End If
Next Word
End Sub

This works on your example text, but it is far from perfect:
- It only works with missing words. If cell B1 contains extra words (but still has a lower total count of words), or a word is spelled differently, all the words after that extra word will be colored red.
- Missing words in B1 that occur more than one time in A1 will also cause weird results

It's a start, maybe it helps and maybe someone else can improve it. I have to go back to work now

 

[arvindmotha]

Th

You could try if this works well enough:

Sub HighlightMissing()

Dim OriginalText() As String
Dim TestText() As String
Dim MissingWords() As String

OriginalText = Split(Range("A1").Value, " ")
TestText = Split(Range("B1").Value, " ")

If UBound(OriginalText) - UBound(TestText) < 0 Then
    MsgBox "Put the longer text in the first cell"
    Exit Sub
End If

ReDim MissingWords(UBound(OriginalText))

j = 0
k = 0
For i = 0 To UBound(OriginalText)
    If OriginalText(i) <> TestText(j) Then
        MissingWords(k) = OriginalText(i)
        k = k + 1 'to add the next missing word
        j = j - 1 'to skip the missing word in TestText in the next iteration
    End If
    If j < UBound(TestText) Then
        j = j + 1
    End If
Next i

If k = 0 Then
    MsgBox "No missing words were found."
    Exit Sub
End If

Range("C1").Value = Range("A1").Value
For Each Word In MissingWords
    If Word <> "" Then
        Range("C1").Characters(InStr(Range("C1").Value, Word), Len(Word)).Font.Color = vbRed
    End If
Next Word
End Sub

This works on your example text, but it is far from perfect:
- It only works with missing words. If cell B1 contains extra words (but still has a lower total count of words), or a word is spelled differently, all the words after that extra word will be colored red.
- Missing words in B1 that occur more than one time in A1 will also cause weird results

It's a start, maybe it helps and maybe someone else can improve it. I have to go back to work now

Thank you for this. It highlights all the words after the particular missing word in B1. So yes this is a good start, Hopefully we can build on from here. Appreciate your help.

 

[Peter_SSs]

Here is another approach that you could try.
I have assumed the texts are in columns A:B, starting in row 2.

The checking is not case-sensitive (but could be) as you will note that "Some" and "some" in row 3 are not highlighted.

Sub DifferentWords()
  Dim RX As Object, M As Object
  Dim a As Variant
  Dim i As Long
  
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.IgnoreCase = True
  Application.ScreenUpdating = False
  With Range("A2", Range("B" & Rows.Count).End(xlUp))
    a = .Value
    .Font.Color = vbRed
    For i = 1 To UBound(a)
      RX.Pattern = "\b(" & Replace(a(i, 1), " ", "|") & ")\b"
      For Each M In RX.Execute(a(i, 2))
        .Cells(i, 2).Characters(M.FirstIndex + 1, M.Length).Font.Color = 0
      Next M
      RX.Pattern = "\b(" & Replace(a(i, 2), " ", "|") & ")\b"
      For Each M In RX.Execute(a(i, 1))
        .Cells(i, 1).Characters(M.FirstIndex + 1, M.Length).Font.Color = 0
      Next M
    Next i
  End With
  Application.ScreenUpdating = True
End Sub

Here is my test sheet after running the code.

 

[arvindmotha]

Th

You could try if this works well enough:

[QUOTE="Peter_SSs, post: 5897876, member: 44226"]
Here is another approach that you could try.
I have assumed the texts are in columns A:B, starting in row 2.

The checking is not case-sensitive (but could be) as you will note that "Some" and "some" in row 3 are not highlighted.

[CODE=vba]
Sub DifferentWords()
  Dim RX As Object, M As Object
  Dim a As Variant
  Dim i As Long
 
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.IgnoreCase = True
  Application.ScreenUpdating = False
  With Range("A2", Range("B" & Rows.Count).End(xlUp))
    a = .Value
    .Font.Color = vbRed
    For i = 1 To UBound(a)
      RX.Pattern = "\b(" & Replace(a(i, 1), " ", "|") & ")\b"
      For Each M In RX.Execute(a(i, 2))
        .Cells(i, 2).Characters(M.FirstIndex + 1, M.Length).Font.Color = 0
      Next M
      RX.Pattern = "\b(" & Replace(a(i, 2), " ", "|") & ")\b"
      For Each M In RX.Execute(a(i, 1))
        .Cells(i, 1).Characters(M.FirstIndex + 1, M.Length).Font.Color = 0
      Next M
    Next i
  End With
  Application.ScreenUpdating = True
End Sub

Here is my test sheet after running the code.

View attachment 66771

[/CODE]

This works on your example text, but it is far from perfect:
- It only works with missing words. If cell B1 contains extra words (but still has a lower total count of words), or a word is spelled differently, all the words after that extra word will be colored red.
- Missing words in B1 that occur more than one time in A1 will also cause weird results

It's a start, maybe it helps and maybe someone else can improve it. I have to go back to work now
[/QUOTE]
Thank you sharing. This worked perfectly well for small texts as shown in your results. But larger text field matches had some anomalies. Even words with no differences were getting highlighted

 

[arvindmotha]

Th


[/CODE]

This works on your example text, but it is far from perfect:
- It only works with missing words. If cell B1 contains extra words (but still has a lower total count of words), or a word is spelled differently, all the words after that extra word will be colored red.
- Missing words in B1 that occur more than one time in A1 will also cause weird results

It's a start, maybe it helps and maybe someone else can improve it. I have to go back to work now

Thank you sharing. This worked perfectly well for small texts as shown in your results. But larger text field matches had some anomalies. Even words with no differences were getting highlighted
[/QUOTE]

 

[Peter_SSs]

@arvindmotha
Your posts are very mixed up. It is hard to work out who you are referring to and what code you have tried. Please clarify.

 

[arvindmotha]

Hi.. sorry if I was unclear.. I tried both the codes and both worked perfectly for short phrases. But not with large texts.. Even words with no differences between cells were getting highlighted as I have given in an example above. Will be great if we can find a way to fix that.