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

Question

我有两个不同的工作表，每个工作表的行数相同。在 R 列中，我有“新”或“旧”，具体取决于行（这是一个动态值）。我想要做的是，如果 Worksheet1 中的一行在 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