Более эффективное удаление строк на двух разных листах на основе значения ячейки [VBA Excel]

Question

У меня есть две разные таблицы с одинаковым количеством строк в каждой. В столбце R у меня есть «Новый» или «Старый» в зависимости от строки (это динамическое значение). Что я хочу сделать, так это, если строка в Worksheet1 содержит «Old» в столбце R, а затем удалить эту строку в Worksheet1 и Worksheet2.

Теперь я попробовал два кода для этого:

Dim w1 As Worksheet
Dim w2 As Worksheet

Set w1= Worksheets("Sheet1")
Set w2= Worksheets("Sheet2")
'-----------------------------------------------------
'Code 1
'-----------------------------------------------------
Application.ScreenUpdating = False
 For r = w1.UsedRange.Rows.Count To 1 Step -1
     If Cells(r, "R") = "Old" Then
         w1.Rows(r).EntireRow.Delete
         w2.Rows(r).EntireRow.Delete
     End If
 Next r
 Application.ScreenUpdating = True
'-----------------------------------------------------
'Code 2
'-----------------------------------------------------

Dim i As Long

i = 1
Application.ScreenUpdating = False
Do While i <= w1.Range("R1").CurrentRegion.Rows.Count

If InStr(1, w1.Cells(i, 18).Text, "Old", vbTextCompare) > 0 Then
    w1.Cells(i, 1).EntireRow.Delete
    w2.Cells(i, 1).EntireRow.Delete
Else
    i = i + 1
End If

Loop
Application.ScreenUpdating = True

Обычно у меня +800 строк, поэтому код 1 работает, как нужно, но иногда это занимает слишком много времени, например, 3 минуты. Код 2 застрял до сих пор.

Какой эффективный способ сделать это?

Answer 1

Удалить строки в листах

Реализация Union должна значительно ускорить процесс.

Код

Sub DeleteRowsInSheets()

    Const cSheet1 As Variant = "Sheet1"    ' First Worksheet Name/Index
    Const cSheet2 As Variant = "Sheet2"    ' First Worksheet Name/Index
    Const cVntCol As Variant = "R"         ' Search Column Letter/Number
    Const cStrCriteria As String = "Old"   ' Search Criteria String

    Dim rngU1 As Range   ' Union Range 1
    Dim rngU2 As Range   ' Union Range 2
    Dim LastUR As Long   ' Last Used Row
    Dim i As Long        ' Row Counter

    With Worksheets(cSheet1)

        ' Calculate Last Used Row.
        If .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), -4123, , 1) _
                Is Nothing Then Exit Sub
        LastUR = .Cells.Find("*", , , , , 2).Row

        ' Add found cells to Union Ranges.
        For i = 1 To LastUR
            If StrComp(.Cells(i, cVntCol), cStrCriteria, vbTextCompare) = 0 Then
                If Not rngU1 Is Nothing Then
                    Set rngU1 = Union(rngU1, .Cells(i, 1))
                    Set rngU2 = Union(rngU2, Worksheets(cSheet2).Cells(i, 1))
                  Else
                    Set rngU1 = .Cells(i, 1)
                    Set rngU2 = Worksheets(cSheet2).Cells(i, 1)
                End If
            End If
        Next

    End With

    ' Delete rows.
    If Not rngU1 Is Nothing Then
        rngU1.EntireRow.Delete ' Hidden = True
        rngU2.EntireRow.Delete ' Hidden = True
        Set rngU2 = Nothing
        Set rngU1 = Nothing
    End If

End Sub

Answer 2

Я думаю, что может быть много формул. Поэтому Application.Calculation = xlManual в начале и Application.Calculation = xlCalculationAutomatic в конце также должны быть хорошей идеей.

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For r = w1.UsedRange.Rows.Count To 1 Step -1
     If Cells(r, "R") = "Old" Then
         w1.Rows(r).EntireRow.Delete
         w2.Rows(r).EntireRow.Delete
     End If
 Next r
Application.ScreenUpdating = true
Application.Calculation = xlCalculationAutomatic