Instr function only on specific font

Question

I´m trying to find a way to use Instr to work only with words that have a specific font.

I´m currently using a code that allows me to find differences between two paragraphs and show the changes on another column by chainging the words that are the same to the color green. The problem is that when using Instr it only finds the first occurence of a word. But with the paragraphs I´m using, the words appear multiple times:

   myLastRow = Cells(Rows.Count, "G").End(xlUp).Row

        For I = 3 To myLastRow
            
     strTemp = " "
    WordsA = Split(Range("F" & I).Text, " ")
    
    Debug.Print WordsA
    WordsB = Split(Range("H" & I).Text, " ")
    Debug.Print WordsB
    
    For ndxB = LBound(WordsB) To UBound(WordsB)
    For ndxA = LBound(WordsA) To UBound(WordsA)
    
        If StrComp(WordsA(ndxA), WordsB(ndxB), vbTextCompare) = 0 Then

    FindText = WordsA(ndxA)
    Debug.Print FindText

    
    Set TextRange = Range("H" & I)
    fontColor = 4
    'FindText.Font.ColorIndex = fontColor
    
    For Each part In TextRange
    
        lenOfpart22 = InStr(1, TextRange, FindText, 1)
        
        lenPart = Len(FindText)

                part.Characters(Start:=lenOfpart22, Length:=lenPart).Font.ColorIndex = fontColor
                
    Next part


    
                Exit For
            End If
        Next ndxA
    Next ndxB
    

      
        Next I

What I need is for the Instr to only search the word if its fond is 0 (black).

TextRange is the paragraph. Usually more than 500 caracters long FindText is the word that I´m searching

This is an example of the problem I´m having:

In this paragraph you can see how some words appear in green. These are the words that are the same on the two paragraphs that I´m comparing (columns F and G). There are some words such as: aeqqw, SAWR, SIGMEL... that are different. The problem is that Instr only finds the first occurrence of a word. That´s why I want a condition were if the word is green, it won´t be considered in the instr and will move on to find the next word.

In the picture you can see that the first "El" is in green, but the rest aren´t. This is because when it searches for the second, thrid, fourth... "el" it comes back to the first "el".

Answer 1

1. Please, use the next function to do what (I understood) you need (playing with arrays...):

Sub WordsComp(cell1 As Range, cell2 As Range) 'punctuation characters eliminated
    Dim arr1() As String, arr2() As String, arrMtch() As String, mtch, El
    Dim strArr As String, i As Long, cleanWord As String, endPlus As Long
    
    arr1 = Split(cell1.value): arr2 = Split(cell2.value) 'split the two cells content by words

    For Each El In arr1                                   'iterate between the first cell words
            For i = 0 To UBound(arr2)
                cleanWord = EndingCharsOut(CStr(El))
                endPlus = Len(cleanWord) - Len(El)
                If EndingCharsOut(CStr(arr2(i))) = cleanWord Then   'when a match has been found:
                    arrMtch = Split(cell2, , i + 1, vbTextCompare)  'split the range only up to the searched word (plus the rest of the string)
                    'eliminate the last element of the array:
                    arrMtch(UBound(arrMtch)) = "@#$%": arrMtch = filter(arrMtch, "@#$%", False)
                    
                    strArr = Join(arrMtch, "|")   'join the array elements to obtain the necessary start, before the word to be colored
                    cell2.Characters(start:=Len(strArr) + 2, length:=Len(El) + endPlus).Font.Color = vbGreen '+ 2 because of the 1D zero based array and a space
                End If
            Next i
    Next
End Sub

Private Function EndingCharsOut(strMatch As String) As String 'eliminates ending punctuation characters (,.?:;)
     With CreateObject("Vbscript.RegExp")
            .Pattern = "[.,/?:;]$"
            If .test(strMatch) Then
                EndingCharsOut = (.Replace(strMatch, ""))
            Else
                EndingCharsOut = strMatch
            End If
    End With
End Function

The above Sub should be called by the next one:

Sub testWordsCompare()
  Dim ws As Worksheet, rng As Range, lastR As Long, i As Long
  
  Set ws = ActiveSheet
  lastR = ws.Range("F" & ws.rows.count).End(xlUp).row
  Set rng = ws.Range("F2:G" & lastR)
    rng.Columns(2).Font.Color = 0 'make the font color black (default)
    
  Application.EnableEvents = False: Application.ScreenUpdating = False
  For i = 1 To rng.rows.count
         WordsComp rng.rows(i).cells(1, 1), rng.rows(i).cells(1, 2)
  Next i
  Application.EnableEvents = True: Application.ScreenUpdating = True
  
  MsgBox "Ready..."
End Sub

The function compares words even containing punctuation (comma, dot, question mark, ":", ";") at the end...

1. A faster solution but not so compact and easy to be understood, would be the next classic one:

Sub compWdClassic(cell1 As Range, cell2 As Range)
    Dim iStart1 As Long, iEnd1 As Long, iStart2 As Long, oldStart As Long, strWd As String
    Dim boolEnd As Boolean, boolOut As Boolean, i As Long, frstW As Boolean, midleW As Boolean
    
    iStart1 = 1 'initialize starting position for Cell1 string
    Do While Not boolEnd
       iEnd1 = InStr(iStart1, cell1, " ", vbBinaryCompare) 'determine the ending of the word to be returned
       strWd = Mid(cell1, iStart1, IIf(iEnd1 > 0, iEnd1 - iStart1, Len(cell1) - iStart1 + 1)) ' extraxting the word to be checked
       If iEnd1 > 0 Then iStart1 = iEnd1 + 1 Else: boolEnd = True 'determine if is it about the last word (or  not)...
       
       strWd = EndingCharsOut(strWd) 'clean the word ending
       
       midleW = False: boolOut = False: iStart2 = 1 'initialize the necessary variables
       Do While Not boolOut 'loop in cell2 value string
            If Not frstW And iStart2 = 1 Then  'if not a first word has been found:
                iStart2 = InStr(IIf(iStart2 = 0, 1, iStart2), cell2, strWd & " ", vbBinaryCompare) 'check against a word without a space in front
                  If iStart2 > 0 Then frstW = True 'first word in the sentence. If such a word found, make the boolean variable True
           Else
                oldStart = iStart2 'memorize the previous value of iStart2
                iStart2 = InStr(iStart2 + 1, cell2, " " & strWd & " ", vbBinaryCompare) 'search if a word with spaces at both sides
                  If iStart2 > 0 Then midleW = True                                                               'if founded, make the boolean variable True
                If oldStart > 0 And midleW Then 'if nothing found before, but a pevious word with spaces of both sides has been found:
                    If iStart2 = 0 Then iStart2 = InStr(oldStart, cell2, " " & strWd, vbBinaryCompare): _
                      If iStart2 > 0 And iStart2 + Len(strWd) = Len(cell2) Then boolOut = True Else: iStart2 = 0: boolOut = True: 'if the last word or only part of a word
                ElseIf oldStart = 0 And Not midleW Then
                    If iStart2 = 0 Then iStart2 = InStr(oldStart + 1, cell2, " " & strWd, vbBinaryCompare):
                      If iStart2 > 0 Then boolOut = True: ' last word and loop must be exited
                End If
            End If
            If iStart2 > 0 Then
                 cell2.Characters(iStart2 + IIf(boolOut, 1, IIf(frstW And Not midleW, 0, 1)), Len(strWd)).Font.Color = vbRed 'do the job
                 iStart2 = iStart2 + Len(strWd) + 1 'increment the variable for the next search
             Else
                If (frstW And Not boolOut) Or (Not frstW And Not midleW And Not boolOut) Then Exit Do 'exiting loop if conditions are met
             End If
        Loop
    Loop
End Sub

It uses the same EndingCharsOut function to clear punctuation characters. You only must call this Sub instead of previous. I mean, replace:

   WordsComp rng.rows(i).cells(1, 1), rng.rows(i).cells(1, 2)

in testWordsCompare sub with:

   compWdClassic rng.rows(i).cells(1, 1), rng.rows(i).cells(1, 2)

Please, send some feedback after testing them...