VBA 根据单元格值删除行

Question

我有一份包含 25K-30K 行的月度报告，我想从中删除基于单元格值的行。该报告每个月的行数是动态的，但列数是固定的，从 A 到 X。我正在使用 For Next 循环在单元格中搜索将触发行删除的值，在工作中sheet 报告的“数据”。此报告中有第二个 sheet 名为“Public 帐户”，宏在其中搜索并将标签（public 或私有）添加到“数据”sheet。然后它使用 For Next 循环检查几个条件（比如如果 R 和 S 列中的单元格的值相等，则删除该行），如果它们为真，则在“数据”sheet 中删除这些行的报告。我的问题是运行（10-15 分钟）的时间太长了。你能帮我加快速度吗？我附上了我正在使用的代码。

Sub Format_Report()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Worksheets("Data").Activate
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("X2").Formula = "=if(isnumber(Match(A2,'Public accounts'!A:A,0)),""Public"",""Private"")"

Range("X2").AutoFill Destination:=Range("X2:X" & LR)

Last = Cells(Rows.Count, "A").End(xlUp).Row

For i = Last To 1 Step -1
    If (Cells(i, "R").Value) = (Cells(i, "S").Value) Then
           Cells(i, "A").EntireRow.Delete
           End If
         Next i

For i = Last To 1 Step -1
    If (Cells(i, "G").Value) = "ZRT" Then
           Cells(i, "A").EntireRow.Delete
           End If
         Next i

For i = Last To 1 Step -1
    If (Cells(i, "G").Value) = "ZAF" Then
           Cells(i, "A").EntireRow.Delete
           End If
         Next i

For i = Last To 1 Step -1
    If (Cells(i, "G").Value) = "E" Then
           Cells(i, "A").EntireRow.Delete
           End If
         Next i
 

           
For i = Last To 1 Step -1
    If Cells(i, 24) = "Public" Then
           Cells(i, 24).EntireRow.Delete
           End If
         Next i

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Answer 1

请测试下一个代码。它应该工作得非常快，使用数组，排序，一次删除，求助和清除助手排序列：

Sub Format_Report()
 Dim wsD As Worksheet, lastRD As Long, lastCol As Long
 Dim arr, arrMark, arrSort, i As Long, boolFound As Boolean

 Set wsD = ActiveSheet 'Worksheets("Data")
 lastRD = wsD.Range("A" & wsD.rows.count).End(xlUp).row
 lastCol = wsD.UsedRange.column + wsD.UsedRange.Columns.count + 1
 arrSort = Evaluate("row(1:" & lastRD & ")") 'build an array to resort after deletion

 wsD.Range("X2:X" & lastRD).Formula = "=if(isnumber(Match(A2,'Public accounts'!A:A,0)),""Public"",""Private"")"
 wsD.Calculate

 arr = wsD.Range("G1:X" & lastRD).Value2 'place the range in an array for faster iteration
 ReDim arrMark(1 To UBound(arr), 1 To 1) 'reDim the array to keep deletion marks

 For i = 1 To lastRD
    If arr(i, 12) = arr(i, 13) And (arr(i, 12) <> "") Or _
           arr(i, 1) = "ZRT" Or _
           arr(i, 1) = "ZAF" Or _
           arr(i, 1) = "E" Or _
           arr(i, 18) = "Public" Then
       arrMark(i, 1) = "Del": boolFound = True 'write in array an boolFound = true to confirm at least a row to be deleted
    End If
 Next i
 Application.ScreenUpdating = False: Application.DisplayAlerts = False
  wsD.cells(1, lastCol).Resize(UBound(arrMark), 1).Value2 = arrMark 'drop arrMark content at once:
  wsD.cells(1, lastCol + 1).Resize(UBound(arrSort), 1).Value2 = arrSort

  'sort the range based on arr column:
  wsD.Range("A1", wsD.cells(lastRD, lastCol + 1)).Sort key1:=wsD.cells(1, lastCol), Order1:=xlAscending, Header:=xlNo ' sort the range by deletion column
  With wsD.cells(1, lastCol).Resize(lastRD, 1)
     If boolFound Then 'if at least a row to be deleted:
        .SpecialCells(xlCellTypeConstants).EntireRow.Delete
     End If
  End With
  'Resort the range based on arrSort column:
  wsD.Range("A1", wsD.cells(lastRD, lastCol + 1)).Sort key1:=wsD.cells(1, lastCol), Order1:=xlAscending, Header:=xlNo
  wsD.cells(lastRD, lastCol + 1).EntireColumn.ClearContents 'clear the column with the initial order
Application.ScreenUpdating = True: Application.DisplayAlerts = True
MsgBox "Ready..."
End Sub

VBA 根据单元格值删除行

VBA Delete lines based on cells values

excel

optimization

vba

for-loop

delete-row