Нужно найти причину торможения макроса (после срабатывания первого, второй макрос начинает сильно тормозить)

Sub Substr()
Dim sSubStr As String    'искомое слово или фраза
    Dim lCol As Long    'номер столбца с просматриваемыми значениями
    Dim lLastRow As Long, li As Long
    Dim avArr, lr As Long
    Dim arr, lInStr&
    Dim t!
    lCol = 2
    If lCol = 0 Then Exit Sub
    t = Timer
    lLastRow = Cells(Rows.Count, "B").End(xlUp).Row '<<< изменено
    'заносим в массив значения листа, в котором необходимо удалить строки
    arr = Cells(1, lCol).Resize(lLastRow, 2).Value
     
    'Получаем с Лист1 значения, которые надо удалить в активном листе
    With Sheets("Лист1")    'Имя листа с диапазоном значений на удаление
        avArr = .Range(.Cells(5, 3), .Cells(.Rows.Count, 3).End(xlUp))
    End With
    'удаляем
    For lr = 1 To UBound(avArr, 1)
        sSubStr = avArr(lr, 1)
        For li = 5 To lLastRow    'цикл с первой строки до конца
 
        
        'Старый вариант
 
'            lInStr = InStr(1, arr(li, 1), sSubStr, 1)
           'Чуть свежее
            'If " " & arr(li, 1) & " " Like "*" & sSubStr & "*" Then '- совсем не точное
            'If " " & arr(li, 1) & " " Like "* " & sSubStr & "*" Then '- не очень точное
            'If " " & arr(li, 1) & " " Like "* " & sSubStr & " *" Then '- точное
            'If " " & arr(li, 1) & " " Like " " & sSubStr & " " Then '- Идеальное :-)
            
            'If " " & LCase(arr(li, 1)) & " " Like "*" & LCase(sSubStr) & "*" Then '- совсем не точное
            If " " & LCase(arr(li, 1)) & " " Like "* " & LCase(sSubStr) & "*" Then '- не очень точное
            'If " " & LCase(arr(li, 1)) & " " Like "* " & LCase(sSubStr) & " *" Then '- точное
            'If " " & LCase(arr(li, 1)) & " " Like " " & LCase(sSubStr) & " " Then '- Идеальное :-)
            
                    arr(li, 2) = "x"
                End If
               
'            If lInStr > 0 Then
'                If lInStr = 1 Then
'                    If Mid$(arr(li, 1), lInStr + Len(sSubStr), 1) = " " Then arr(li, 2) = "x"
'                ElseIf lInStr - 1 + Len(sSubStr) = Len(arr(li, 1)) Then
'                    If Mid$(arr(li, 1), lInStr - 1, 1) = " " Then arr(li, 2) = "x"
'                Else
'                    If Mid$(arr(li, 1), lInStr - 1, 1) = " " And Mid$(arr(li, 1), lInStr + Len(sSubStr), 1) = " " Then arr(li, 2) = "x"
'                End If
'            End If
        Next li
    Next lr
    Application.ScreenUpdating = 0
    For li = 5 To lLastRow    'цикл с первой строки до конца
        'If Len(arr(li, 2)) Then Cells(li, 3).Interior.Color = 65535 '-было
        If arr(li, 2) = "x" Then Cells(li, 2).Interior.Color = 65535
    Next
    Application.ScreenUpdating = 1
    Debug.Print Format(Timer - t, "0.0000")
End Sub