VBA Delete lines based on cells values-CodePudding

I have a monthly report with 25K-30K lines from which I want to delete lines based on cell values. The report has a dynamic number of rows each month but the number of columns are fixed, from A to X. I am using the For Next Loop to search into the cells for the values that will trigger the deletion of rows, in the worksheet "Data" of the report. There is a second sheet in this report named "Public accounts" where the macro searches and adds a tag (public or private) into each of the rows in the "Data" sheet. It then checks several conditions (like if the values of the cells in columns R and S are equal then the line is deleted) using the For Next loop and if they are true the lines are deleted in the "Data" sheet of the report. My problem is that it takes far too long to run (10-15 mins) in its condition. Can you please help me to speed it up? I am attaching the code that I am using.

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

CodePudding user response：

Please, test the next code. It should work very fast, using arrays, sort, delete at once, resort and clear the helper sort column:

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