Slow process on deleting rows - How to make faster?

Question

I have a several macros within my workbook. This is the only one that seems to be really slow 3-5 minutes on a 2500 row sheet.

The purpose is if Row is between date dtFrom and dtUpTo Then delete entire row.

I added to pause and resume calculations and that boosted it slightly

Anyone have any ideas on how to make this faster?

Sub DeleteRows
    '--- Pause Calculations:
    Application.Calculation = xlManual
    '----- DELETE ROWS -----
    Dim dtFrom As Date
    Dim dtUpto As Date
    Dim y As Long
    Dim vCont As Variant
    dtFrom = Sheets("Control Panel").Range("D5").Value
    dtUpto = dtFrom + 6
    Sheet1.Range("D1").Value2 = "Scanning, Please wait..."
    With Sheets("Database")
        For y = Sheet5.Cells(Sheet5.Rows.Count, 2).End(xlUp).Row + 1 To 2   Step -1
            vCont = .Cells(y, 1).Value
            If Not IsError(vCont) Then
                If vCont >= dtFrom And vCont <= dtUpto Then
                    .Rows(y).EntireRow.Delete
                End If
            End If
        Next
    End With
    '--- Resume Calculations:
    Application.Calculation = xlAutomatic
   End Sub

Thanks!

Answer 1

Deleting a large number of individual rows is best done in a single operation. Rory has demonstrated the Union method of creating a collection of discontiguous rows to be deleted with one Range.Delete operation.

While the Union method much better than looping through individual rows looking for rows to delete, this still suffers from the CPU intensive operation of deleting (and shifting) many discontiguous rows of data. If the rows can be expediently shifted into a single block, the .Delete method will work much faster. A Range.Sort method might seem like more work but it will be faster overall.

Option Explicit

Sub DeleteRows()
    
    Dim dtFrom As Date
    Dim dtUpto As Date
    Dim y As Long
    Dim d As Long, vDTs As Variant
    
    'appTGGL bTGGL:=False  '<~~ uncomment when finished debugging>
    
    dtFrom = Sheets("Control Panel").Range("D5").Value2
    dtUpto = dtFrom + 6
    Sheet1.Range("D1") = "Scanning, Please wait..."
    
    'is this supposed to be Database or Sheet5? Are you mixing names and codenames?
    With Worksheets("Database")
        With .Cells(1, 1).CurrentRegion
            With .Resize(.Rows.Count - 1, 1).Offset(1, 0)
                vDTs = .Value2
                For d = LBound(vDTs, 1) To UBound(vDTs, 1)
                    vDTs(d, 1) = IIf(vDTs(d, 1) >= dtFrom And vDTs(d, 1) <= dtUpto, 1, 0)
                Next d
            End With
            With .Resize(.Rows.Count - 1, 1).Offset(1, .Columns.Count)
                .Cells = vDTs
            End With
        End With
        
        'reestablish the new currentregion
        With .Cells(1, 1).CurrentRegion
            .Cells.Sort key1:=.Columns(.Columns.Count), order1:=xlAscending, _
                        Orientation:=xlTopToBottom, Header:=xlYes
            d = Application.Match(1, .Columns(.Columns.Count), 0)
            'one big block of rows to delete
            .Cells(d, 1).Resize(.Rows.Count - d, 1).EntireRow.Delete
            'done with the helper column
            .Columns(.Columns.Count).EntireColumn.Delete
        End With
        
    End With
    
    appTGGL

End Sub

Sub appTGGL(Optional bTGGL As Boolean = True)
    Application.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
    Application.EnableEvents = bTGGL
    Application.DisplayAlerts = bTGGL
    Application.ScreenUpdating = bTGGL
    Application.Cursor = IIf(bTGGL, xlDefault, xlWait)
    Debug.Print Timer
End Sub

I magnified the problem by testing this on 50,000 rows (20× the 2500 row sheet you are dealing with) and it took only a few seconds. The code looks, like it is doing a lot more work but it accomplishes the task in record time.

Answer 2

Try only doing one delete operation on all the relevant rows at the end:

Sub DeleteRows()
'--- Pause Calculations:
    Application.Calculation = xlManual
    '----- DELETE ROWS -----
    Dim dtFrom                As Date
    Dim dtUpto                As Date
    Dim y                     As Long
    Dim vCont                 As Variant
    Dim rDelete As Range
    dtFrom = Sheets("Control Panel").Range("D5").Value
    dtUpto = dtFrom + 6
    Sheet1.Range("D1").Value2 = "Scanning, Please wait..."
    With Sheets("Database")
        For y = Sheet5.Cells(Sheet5.Rows.Count, 2).End(xlUp).Row + 1 To 2 Step -1
            vCont = .Cells(y, 1).Value
            If Not IsError(vCont) Then
                If vCont >= dtFrom And vCont <= dtUpto Then
                    If rDelete Is Nothing Then
                        Set rDelete = .Rows(y)
                    Else
                        Set rDelete = Union(rDelete, .Rows(y))
                    End If
                End If
            End If
        Next
    End With
    If Not rDelete Is Nothing Then rDelete.EntireRow.Delete
    '--- Resume Calculations:
    Application.Calculation = xlAutomatic
End Sub

Note: You could also use an autofilter here.