查找特定值，删除相应范围。 宏异常缓慢

Question

In my spreadsheet I have something close to 2,000 rows. I need to search through these rows, find a specific date (current date), and then delete a corresponding range. It however runs very very slowly. Any suggestions about how I can make it run faster? I was thinking that maybe I could organize my rows based on the date (current date will always be the oldest and therefore be on the top) and then delete all of the rows at once with a Range(XX:XX").Delete. But I don't know how to find where the last row with Currentdate would be as it is going to be constantly changing.

Sub ChangeandDelete
 MudaDataLCA
 DeleteDateLCA
End Sub

Sub MudaDataLCA()
'===Muda Data Atual ABERTURA===
Dim Affected As Workbook
Dim Dados As Worksheet
Dim LastRow As Long


Set Affected = Workbooks("Controle de Lastro LCA_FEC - Test")
Set Dados = Affected.Sheets("DADOS")
Dados.Activate
    Dim CurrentDate As Date
    CurrentDate = Range("AH2") + 1
    Range("AH2") = CurrentDate


End Sub
Sub DeleteDateLCA()
Dim Affected As Workbook
Dim Dados As Worksheet
Dim LastRow As Long

Set Affected = Workbooks("Controle de Lastro LCA_FEC - Test")
Set Dados = Affected.Sheets("DADOS")
Dados.Activate

LastRow = Dados.Cells(Rows.Count, "P").End(xlUp).Row
    For i = 5 To LastRow
        Do While Range("S" & i).Value = Range("AH2")
        Range("P" & i & ":AG" & i).Delete
        Loop
    Next i

End Sub

Answer 1

This method of filtering for the updated date in AH2 should speed the process up significantly.

Sub ChangeandDelete()
    Dim fr As Long, lr As Long, fString As String
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    With Workbooks("Controle de Lastro LCA_FEC - Test").Sheets("DADOS")
        .Range("AH2") = CDate(.Range("AH2").Value + 1)
        fr = 4: lr = .Cells(Rows.Count, "P").End(xlUp).Row
        fString = Chr(61) & Format(.Range("AH2").Value, .Range("P5").NumberFormat)
        With .Range(.Cells(fr, "P"), .Cells(lr, "P"))
            .AutoFilter
            .AutoFilter Field:=1, Criteria1:=fString
            If CBool(Application.Subtotal(102, .Columns(1)) + IsNumeric(.Cells(1, 1).Value2)) Then
                With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
                    .SpecialCells(xlCellTypeVisible).EntireRow.Delete
                End With
                Debug.Print Application.Count(.Columns(1))
            End If
            .AutoFilter
        End With
    End With
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

I've assumed that at least part of the slowdown was formula recalculation every time a row was deleted and this would indicate automatic calculation. I've turned off automatic calculation and restored it once the process is complete. There are other methods of storing the current state of the workbook/worksheet calculation, turning calculation off, then restoring the original state.

Answer 2

So I've got two answers. I put in 39000 rows of data and did it with 7500 rows that would meet the criteria for deleting - so I could test the time (64bit windows 7)

Loops can be super slow but I'll write this one first because it's closest to your code:

Sub DeleteIT()

Dim deleteRange As Range
Dim deleteValue As Date
Dim lastRow As Long

Set affected = ThisWorkbook
Set dados = affected.Sheets("DADOS")

Dim CTtimer As CTimer
'Set CTtimer = New CTimer
'Dados.Activate
    Application.ScreenUpdating = False

deleteValue = dados.Range("AH2")
lastRow = dados.Range("S" & dados.Rows.Count).End(xlUp).Row
 'CTtimer.StartCounter
    Do
        Set deleteRange = Range("S5:S" & lastRow).Find(what:=deleteValue, LookIn:=xlValues, _
            lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)

        If Not deleteRange Is Nothing Then deleteRange.Range(Cells(1, 1), Cells(1, 18)).Offset(0, -3).Delete
    Loop While Not deleteRange Is Nothing
'MsgBox CTtimer.TimeElapsed

Application.ScreenUpdating = True

End Sub

I got throught about 500 rows and 150 deletes of matching records in 4 mins with the above code. I did a code break and stopped because nobody should have to deal with that haha..

My other idea(below) is more along the lines of your sort idea, this way only took about 25 seconds to do 30500 deletes from 31500 rows.

Sub aReader()
Dim affected As Workbook
Dim SheetName As String
Dim deleteValue As Date
Dim population As Range
Dim lastRow As Long
Dim x As Long
'Dim CTtimer As CTimer
'Set CTtimer = New CTimer
Set affected = ThisWorkbook

Application.ScreenUpdating = False

SheetName = "DADOS"

deleteValue = affected.Worksheets(SheetName).Range("AH2")

Set population = Worksheets(SheetName).Range("P5", Sheets(SheetName).Range("P5").End(xlDown))
'CTtimer.StartCounter

For x = 1 To population.Count

    If population.Cells(x, 4).Value = deleteValue Then Range(population.Cells(x, 1), population.Cells(x, 18)).Value = ""

Next x

Range("P5:AG" & (population.Count + 4)).Sort key1:=Range("S5:S" & population.Count + 4), _
   order1:=xlAscending, Header:=xlNo

Application.ScreenUpdating = True
'MsgBox CTtimer.TimeElapsed
End Sub