Удалить строку на основе значения в столбце

Question

У меня есть следующий код, который работает, т.е. удаляет строку на рабочем листе, когда указанный столбец c имеет значение «РАСПРЕДЕЛЕНО»

Sub RemoveRows()

Dim i As Long
Dim strtest As String

i = 1

Do While i <= ThisWorkbook.ActiveSheet.Range("AG1").CurrentRegion.Rows.Count

strtest = ThisWorkbook.ActiveSheet.Cells(i, 33).Text
    If ThisWorkbook.ActiveSheet.Cells(i, 33).Text = "PAID" Then
        ThisWorkbook.ActiveSheet.Cells(i, 33).EntireRow.Delete
    Else
        i = i + 1
    End If

Loop

End Sub

Однако это очень медленно на рабочем листе с 5000 строк .

Есть идеи, как сделать это намного быстрее?

Answer 1

Пара вещей, которые вы можете попробовать:

• Добавить оператор «Делать события» в точке цикла. Это «DoEvents - это команда Excel VBA, которая временно приостанавливает выполнение макроса для обновления sh экрана и выполнения любых ожидающих событий в Excel». Например:

   Do
       ' code execution... 

        DoEvents

    Loop Until rowB = "" Or rowB11 = ""

• Перед циклом вы можете добавить инструкцию «Application.ScreenUpdating = False». Это отключает блики sh, которые вы видите на листе во время обработки.

    Application.ScreenUpdating = False

Answer 2

Существует несколько причин, которые могут повлиять на скорость выполнения кода, включая подход / метод кодирования. Ниже приведен исправленный код с комментариями.

Sub RemoveRowsV2()

Dim i As Long
Dim strtest As String
Dim rngDel As Range

i = 1

'\\ Control features which may affect code processing!
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Do While i <= ThisWorkbook.ActiveSheet.Range("AG1").CurrentRegion.Rows.Count
    '\\ Build a union of all cells to be deleted
    strtest = ThisWorkbook.ActiveSheet.Cells(i, 33).Value
    If ThisWorkbook.ActiveSheet.Cells(i, 33).Value = "PAID" Then
        If rngDel Is Nothing Then 
            Set rngDel = ThisWorkbook.ActiveSheet.Cells(i, 33)
        Else
            Set rngDel = Union(rngDel, ThisWorkbook.ActiveSheet.Cells(i, 33))
        End If
    Else
        i = i + 1
    End If

Loop
'\\ Delete them once
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete

'\\ Reset features which may affect code processing!
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic


End Sub

В качестве альтернативы вы можете использовать макро-рекордер для получения первичного кода, основанного на автофильтре, как предложил @BigBen!