VBA скопировать красные строки на новый лист

Question

Я использую два кода в своих книгах аудита для создания сводной таблицы исправлений. У меня проблемы со вторым кодом, который предназначен для поиска любой строки с красным текстом и копирования ее на новый лист. Я верю, что это может сделать то, что я намереваюсь, но это блокирует мой компьютер Любые предложения будут полезны.

Sub correction()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lastRow As Long, j As Long
    Set ws1 = ThisWorkbook.ActiveSheet
    Set ws2 = ThisWorkbook.Sheets("ERC DATABASE CORRECTION")
    lastRow = Cells(Rows.Count, "A").End(xlUp).row
    For j = 3 To 8000
        Dim rng As Range
        Dim row As Range
        Dim cell As Range
        Set rng = Range("H3:BF9000")
        For Each row In rng.Rows
            For Each cell In row.Cells
                For i = 1 To Len(cell.Value)
                    If cell.Characters(i, 1).Font.Color = vbRed _
                                        And cell.Value <> "" Then
                        lastRow = lastRow + 1
                        ws1.Rows(j).EntireRow.Copy ws2.Range("A" & lastRow)
                    End If
                Next i
            Next cell
        Next row
    Next j
End Sub