try:
Sub blah2()
For Each cll In Sheets("USA").UsedRange.Cells
myPhrase = Trim(cll.Value)
phraseLength = Len(myPhrase)
For j = phraseLength To 4 Step -1
For i = 1 To phraseLength - 3
myNewPhrase = Trim(Mid(myPhrase, i, j))
myNewPhraselength = Len(myNewPhrase)
If myNewPhraselength > 0 Then
clr = cll.Font.Color
For Each sht In ThisWorkbook.Sheets
If sht.Name <> "USA" Then
For Each celle In sht.UsedRange
x = InStr(1, celle.Value, myNewPhrase, vbTextCompare)
If x > 0 Then
celle.Characters(Start:=x, Length:=myNewPhraselength).Font.Color = clr
Do
x = InStr(x + 1, celle.Value, myNewPhrase, vbTextCompare)
If x > 0 Then celle.Characters(Start:=x, Length:=myNewPhraselength).Font.Color = clr
Loop Until x = 0
End If
Next celle
End If
Next sht
End If
Next i
Next j
Next cll
End Sub
It uses a brute force technique so be prepared to wait (15 secs here).