Excel is slow after running macro, is there a way to improve my code?

Question

I have written a macro that highlights keywords in column "Y". Script does work and does exactly what I need, but it slows down excel a lot, like it is still doing something. My guess is it has to do with FOR loop, but I'm not sure how to fix it.

My VBA knowledge is very limited and this is as far as I got with googling for solution. I am hopeful someone can help me with my code.

Sub HighlightKeywords()

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False

Dim sPos As Long, sLen As Long
Dim rng As Range
Dim findMe As String
Dim i As Integer
Dim t As Integer
Dim SearchArray

SearchArray = Array("WORD1", "WORD2")


For t = 0 To SearchArray

Set rng = Range("Y2:Y1000")
findMe = SearchArray(t)

For Each rng In rng
    With rng
        If LCase(rng.Value) Like "*" & LCase(findMe) & "*" Then
            If Not rng Is Nothing Then
                For i = 1 To Len(rng.Value)
                    sPos = InStr(i, UCase(rng.Value), UCase(findMe))
                    sLen = Len(findMe)

                    If (sPos <> 0) Then
                        rng.Characters(Start:=sPos, 
Length:=sLen).Font.Color = RGB(255, 0, 0)
                        i = sPos + Len(findMe) - 1
                    End If
                Next i
            End If
        End If
    End With
Next rng

Next t

Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Answer 1

Try this one.

I just remove whatever could be not needed and whatever I think could work wrong. Anyhow, I did not test as I don´t know the real utility of it.

Sub HighlightKeywords()
Dim sPos As Long, sLen As Long
Dim rng As Range
Dim Sample As Range
Dim i As Integer
Dim t As Integer
Dim SearchArray

With Application 
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .DisplayStatusBar = False
    .EnableEvents = False
End With

SearchArray = Array("WORD1", "WORD2")
Set rng = Range("Y2:Y1000")

For t = 0 To Ubound(Array, 1) 'Are you sure to look for item 0?
    For Each Sample In rng
        With Sample
            If LCase(.Value) Like "*" & LCase(SearchArray(t)) & "*" And Not .Value Is Nothing Then
                For i = 1 To Len(.Value)
                    sPos = InStr(i, UCase(.Value), UCase(SearchArray(t)))
                    sLen = Len(SearchArray(t))
                    If (sPos <> 0) Then
                        .Characters(Start:=sPos, Length:=sLen).Font.Color = RGB(255, 0, 0)
                        i = sPos + Len(SearchArray(t)) - 1
                    End If
                Next i
            End If
        End With
    Next
Next t

With Application 
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
    .DisplayStatusBar = True
    .EnableEvents = True
End With    

End Sub

Hope it helps.