以更有效的方式根据单元格值删除两个不同工作表上的行 [VBA Excel]

Question

I have a two different worksheets with the same number of rows each one. In column RI have "New" or "Old" depending on the row (this is a dynamic value). What I want to do is, if a row in Worksheet1 contains "Old" in column R, then delete that row in both Worksheet1 and Worksheet2.

Now, I have tried two codes for this:

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

Usually I have +800 rows, so Code 1 works as desired but it sometimes takes too long, like 3 minutes. Code 2 gets stuck so far.

What is an efficient way of doing this?

Answer 1

Delete Rows In Sheets

Implementing Union should considerably speed up the process.

The Code

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

I think that there could be lots of formulas. So Application.Calculation = xlManual at the begining and Application.Calculation = xlCalculationAutomatic at the end should be good idea too.

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