基于单元格值的VBA删除线

Question

我有一个每月的报告，其中有25k-30k线，我想从中根据单元格值删除行。该报告每个月都有动态数的行数，但列的数量是固定的，从a到X。我正在使用下一个循环来搜索单元格中的值，以获取将触发工作表中的行删除的值，“在工作表中”报告的数据。该报告中有第二个表格“公共帐户”，其中宏搜索并在“数据”表中的每个行中添加标签（公共或私有）。然后，它使用下一个循环检查了几个条件（例如，R和S中的单元格值相等，则删除了线路），如果它们是正确的，则该线将在报告的“数据”表中删除。 我的问题是，在其状态下运行（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