Can this code be speeded up?

[CLR]

Hi All.......
Below is code that works fine, it just takes a long time to run and I was
hoping someone could give me an idea how to speed it up.....like by cutting
the time in half or better......the idea behind it is that on a 3500 row
database, each row has a date in column Q that is the first day of the month
only. This macro effectively deletes all rows whose date equals the oldest
date in column Q. Incidently, if I use "delete" instead of "clearcontents
and then sort", it causes a reduction of the size of the database each time
it's run, which is unacceptable.

Here's the code:
Sub DeleteTheOldestMonth()
Dim lastrow As Long, r As Long
Dim oldest As String
Range("data!k1").Value = "=min(ALL12!Q13:Q10000)" 'col Q contains dates
'using the first day of each month only
oldest = Range("data!k1").Value
Sheets("ALL12").Select
lastrow = Cells(Rows.Count, "a").End(xlUp).Row
For r = lastrow To 13 Step -1

If Cells(r, "Q").Value Like oldest Then
Rows(r).EntireRow.ClearContents
End If
Next r

'Sort the database, firstkey col A, secondkey col Q to eliminate blank rows
'without changing the RANGE of the database, A12:S10000
Range("A12:z10000").Select
Selection.Sort Key1:=Range("A12"), Order1:=xlAscending,
Key2:=Range("Q12" _
), Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=
_
False, Orientation:=xlTopToBottom

Range("A12").Select
End Sub

TIA
Vaya con Dios,
Chuck, CABGx3

 

[Jim Thomlinson]

Every time you clear contents XL will have to recalculate. That will slow
things down substantially. There are 2 ways to deal with that. One is to make
one big range to be cleared all at once. The other is to temporarily suspend
calculation. Since you are only clearing contents and not deleting I might be
more inclined to just suspend calculations. Additionally if you suspend
screen updaing that should speed things up...

One note is to change xlGuess to xlYes or xlNo in yoru sort depending on
whether you have a header row or not. xlGuess leaves xl to guess what you
want.

Sub DeleteTheOldestMonth()
Dim lastrow As Long, r As Long
Dim oldest As String

With Application
..ScreenUpdating = False
..Calculation = xlCalculationManual
End With

Range("data!k1").Value = "=min(ALL12!Q13:Q10000)" 'col Q contains dates
'using the first day of each month only

oldest = Range("data!k1").Value
With Sheets("ALL12")
lastrow = .Cells(.Rows.Count, "a").End(xlUp).Row
For r = lastrow To 13 Step -1

If .Cells(r, "Q").Value Like oldest Then
.Rows(r).EntireRow.ClearContents
End If
Next r
End With
'Sort the database, firstkey col A, secondkey col Q to eliminate blank rows
'without changing the RANGE of the database, A12:S10000
.Range("A12:z10000").Sort Key1:=Range("A12"), Order1:=xlAscending, _
Key2:=Range("Q12"), Order2:=xlAscending, _
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom

'Range("A12").Select
With Application
..ScreenUpdating = False
..Calculation = xlCalculationAutomatic
End With

End Sub

 

[CLR]

Hi Jim.........

It's unbelievable how much improvement your changes make!!!.......just
amazing. Thank you so much, kind Sir.

Vaya con Dios,
Chuck, CABGx3