Instr function only on specific font - excel

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

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...
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...