update the code to work in the fastest way possible

[sr1111]

I got the below code while searching in MrExcel.
My request is to update the code to work in the fastest way possible. I have many thousands of rows of data and it is taking hours.
The code should not work in the sheet "Secret code". Please help.

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

 

[johnnyL]

Solution would be a 'smarter' For loop structure. What that would be is beyond my thinking at this point in time.

 

[sr1111]

oh! Then it is not easy.