Find Specific Value, Delete Corresponding Range. Macro agonozingly slow - vba

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