Macro speed decreesing after each run

[Scott]

I have a macro that refreshes a query to a database on the network,
returns the data and then the macro goes thru the data and creates a
formated output of just the data from the query that is needed. It
deletes most of the lines of data from the query and only keeps the
few that it needs.
My problem is that every time I run the macro it takes 4-5 seconds
longer each time. Here are my timings, 8,12,17,21,25,30,34,38,42,47
I have searched on clearing memory and have not found anything
helpfull. I have turned off autocaclulate and other correction options
in Excel but see the same increase in run time.
If I close the spreadsheet and open it again it start over at about 8
seconds and each sucsesive run takes 4-5 seconds longer again. I do
have a user form that pops up but it gets unloaded.

Anythought sour suggestions as to where to start looking?

Thanks
Scott

 

[Scott]

I just discovered that if I save the workbook after running the macro
the next time I run it, it starts over at the faster speed but
increases each time I run it again until I save again.
Is it "remembering" something? My undo is grayed out so there is
nothing in the undo cache.

Scott

 

[rumkus]

I just discovered that if I save the workbook after running the macro
the next time I run it, it starts over at the faster speed but
increases each time I run it again until I save again.
Is it "remembering" something? My undo is grayed out so there is
nothing in the undo cache.

Scott

If you give us the number of rows and the code itself people might
give you some idea of course.
My first guess is the deletion of rows that takes time.
Do you sort your data before deleting ?
Or did you try filter/copy/move method ?
Rgds

 

[eliano]

I just discovered that if I save the workbook after running the macro
the next time I run it, it starts over at the faster speed but
increases each time I run it again until I save again.
Is it "remembering" something? My undo is grayed out so there is
nothing in the undo cache.

Scott

Please, Office version & Operative System. Tks

 

[Scott]

Win XP, Excel 2007 (12.0.6535.5002) SP2

The code is pretty long is why I didnt post it initially. I put
several timers throughout the code and found the section taking the
time.
Here is the code taking a long time. I did not write it.
Range("D2").Select
Do While ActiveCell.Value <> Empty
If ActiveCell = caln And ActiveCell.Offset(0, 4) = 1 Then
ActiveCell.Offset(1, 0).Select
sh1ft = sh1ft + 1
ElseIf ActiveCell = caln + 1 And ActiveCell.Offset(0, 4) = 3
Then
ActiveCell.Offset(1, 0).Select
sh3ft = sh3ft + 1
ElseIf ActiveCell = caln And ActiveCell.Offset(0, 4) = 2 Then
ActiveCell.Offset(1, 0).Select
sh2ft = sh2ft + 1
Else
Range(ActiveCell.Offset(0, -3), ActiveCell.Offset(0,
4)).Delete
End If
Loop

I have found that selecting is a bad thing especially when you have to
process many lines. The data the code was having to go thru was around
700 rows long. Here is my new code. It runs pretty good and stays
pretty consistant each time it runs with the same data to process.

ar = 2 'active row
Do While Cells(ar, 4).Value <> Empty
If Cells(ar, 4) = caln And Cells(ar, 8) = 1 Then
ar = ar + 1
sh1ft = sh1ft + 1
ElseIf Cells(ar, 4) = caln + 1 And Cells(ar, 8) = 3 Then
ar = ar + 1
sh3ft = sh3ft + 1
ElseIf Cells(ar, 4) = caln And Cells(ar, 8) = 2 Then
ar = ar + 1
sh2ft = sh2ft + 1
Else
Rows(ar).Delete
End If
Loop

The code is basically looking for the date in column 4 to match caln
and the shift to match 1,2,3. When both match it counts up the # of
each shift or if they dont match it deletes the entire row.
I would appreciate any suggestions anyone has on making such a routine
work faster.

Thanks
Scott

 

[Jim Cone]

Untested...
'---

'From the bottom up...
ar = Cells(Rows.Count, 4).End(xlUp).Row
Do While Not IsEmpty(Cells(ar, 4))
If Cells(ar, 4).Value = caln Then
If Cells(ar, 8).Value = 1 Then
sh1ft = sh1ft + 1
ElseIf Cells(ar, 8).Value = 2 Then
sh2ft = sh2ft + 1
End If
ElseIf Cells(ar, 4).Value = caln + 1 Then
If Cells(ar, 8).Value = 3 Then sh3ft = sh3ft + 1
Else
Rows(ar).Delete
End If
ar = ar - 1
Loop
'---
Jim Cone
Portland, Oregon USA
http://www.contextures.com/excel-sort-addin.html

..
..
..

"Scott" <[email protected]>
wrote in message
Win XP, Excel 2007 (12.0.6535.5002) SP2

The code is pretty long is why I didnt post it initially. I put
several timers throughout the code and found the section taking the
time.
Here is the code taking a long time. I did not write it.
-snip-
I have found that selecting is a bad thing especially when you have to
process many lines. The data the code was having to go thru was around
700 rows long. Here is my new code. It runs pretty good and stays
pretty consistant each time it runs with the same data to process.

ar = 2 'active row
Do While Cells(ar, 4).Value <> Empty
If Cells(ar, 4) = caln And Cells(ar, 8) = 1 Then
ar = ar + 1
sh1ft = sh1ft + 1
ElseIf Cells(ar, 4) = caln + 1 And Cells(ar, 8) = 3 Then
ar = ar + 1
sh3ft = sh3ft + 1
ElseIf Cells(ar, 4) = caln And Cells(ar, 8) = 2 Then
ar = ar + 1
sh2ft = sh2ft + 1
Else
Rows(ar).Delete
End If
Loop

The code is basically looking for the date in column 4 to match caln
and the shift to match 1,2,3. When both match it counts up the # of
each shift or if they dont match it deletes the entire row.
I would appreciate any suggestions anyone has on making such a routine
work faster.
Thanks
Scott

 

[rumkus]

Dear Scott, below sub might give you some idea how helper columns can
be used deleting unwanted rows.
Sheet pickuptime2 has 20.000 plus rows and the code works with
lighting speed..
Simply put the sub deletes some of data when they get older than 30
days.

Sub cleantours()

Dim rngA As Range
Dim rngB As Range
Dim rngC As Range

Dim strA As String
Dim strB As String
Dim strC As String

Call sortpickuptime2

Set rngA = Application.Intersect(Worksheets("pickuptime2") _
.Range("h2:h65526"), Worksheets("pickuptime2").UsedRange.EntireRow)
Set rngB = Application.Intersect(Worksheets("pickuptime2") _
.Range("I2:I65526"), Worksheets("pickuptime2").UsedRange.EntireRow)
Set rngC = Application.Intersect(Worksheets("pickuptime2") _
.Range("j2:j65526"), Worksheets("pickuptime2").UsedRange.EntireRow)

strA = "=IF(G2="""","""",ISNUMBER(MATCH(G2,sale!$V$2:$V$50000,0)))"
strB = "=IF(B2="""","""",(B2<TODAY()))"
strC =
"=IF(A2="""","""",IF(B2+30<TODAY(),"""",IF(AND(H2=FALSE,I2=TRUE),"""",""a"")))"

rngA.Formula = strA
rngB.Formula = strB
rngC.Formula = strC


With Application.Intersect(Worksheets("pickuptime2") _
.Range("j2:j65526"), Worksheets("pickuptime2").UsedRange.EntireRow)
.Value = .Value
End With

Application.Intersect(Worksheets("pickuptime2") _
.Range("j2:j65526"), Worksheets("pickuptime2").UsedRange.EntireRow)
_
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Application.Intersect(Worksheets("pickuptime2") _
.Range("h2:j65526"), Worksheets("pickuptime2").UsedRange.EntireRow)
_
.ClearContents

Set rngA = Nothing
Set rngB = Nothing
Set rngC = Nothing

End Sub