Excel работает медленно после запуска макроса, есть ли способ улучшить мой код?

Question

Я написал макрос, который выделяет ключевые слова в столбце «Y». Скрипт работает и делает именно то, что мне нужно, но он сильно тормозит, как будто он все еще что-то делает. Я предполагаю, что это связано с циклом FOR, но я не уверен, как это исправить.

Мои знания по VBA очень ограничены, и это все, что я нашел в поиске решений. Я надеюсь, что кто-то может помочь мне с моим кодом.

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

Попробуйте это.

Я просто удаляю все, что может не понадобиться, и все, что, по моему мнению, может работать неправильно. Во всяком случае, я не тестировал, так как не знаю его реальной полезности.

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

Надеюсь, это поможет.