excel - 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

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.