I have a macro that contains a loop that basically performs a series of copy & paste procedures. The number of rows can vary, up to a max of 1500. After each copy/paste, I clear the clipboard using Application.CutCopyMode = False. I have run multiple iterations of this macro with consistently the same issue ... the first time I run the macro, it takes about 1-1/2 minutes to process. The second time I run it (without saving the file or doing anything else), it processes in roughly the same amount of time. The third time I run it, the processing triples or quadruples, and each subsequent attempt after that increase time as well. The interesting thing is that if I completely exit Excel, then re-open Excel & re-open the file, it seems to "clear" the cache and the macro takes 1-1/2 minutes again. I have gone through this routine at least 5 times with the same end result. Is there ANY type of code that can be used to clear the Excel cache (not just the internal clipboard) that can remedy my problem? It is simply not practical to ask users to constantly save file, close Excel, reopen Excel, reopen file, run macro!!
FYI, I've posted my code below:
Sub Consolidate_records()
Sheets("EventMerge").Range("BS5").Value = Now()
Rows("27:" & CStr(Range("BR16").Value + 26)).Select
Selection.RowHeight = 9.75
Range("BS" & CStr(Range("BR16").Value + 26)).Select
Application.Calculation = xlManual
Do Until ActiveCell.Offset(0, -56).Value = "1st Event Row"
If ActiveCell.Offset(0, -56).Value = 0 Then
ActiveCell.Offset(0, 0).Range("A1:CA1").Copy
ActiveCell.Offset(-1, 0).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, SkipBlanks:=True
Application.CutCopyMode = False
Else
ActiveCell.Offset(-1, 0).Select
End If
Loop
'Then delete rows that are not the "1st event row"
If Range("N23").Value > 0 Then
Range("A27:DS50000").Select
ActiveWorkbook.Worksheets("EventMerge").Sort.SortFields.add Key:=Range( _
"O27:O50000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveSheet.Range("$A$26:$DS$50000").AutoFilter Field:=15, Criteria1:="0"
Range("A27:A" & CStr(Range("BR16").Value + 26)).Select
Selection.ClearContents
Selection.EntireRow.Delete
Else
End If
If ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
Application.Calculation = xlAutomatic
Sheets("EventMerge").Range("BS6").Value = Now()
Range("BV5").Value = Range("BS7").Value
End Sub
FYI, I've posted my code below:
Sub Consolidate_records()
Sheets("EventMerge").Range("BS5").Value = Now()
Rows("27:" & CStr(Range("BR16").Value + 26)).Select
Selection.RowHeight = 9.75
Range("BS" & CStr(Range("BR16").Value + 26)).Select
Application.Calculation = xlManual
Do Until ActiveCell.Offset(0, -56).Value = "1st Event Row"
If ActiveCell.Offset(0, -56).Value = 0 Then
ActiveCell.Offset(0, 0).Range("A1:CA1").Copy
ActiveCell.Offset(-1, 0).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, SkipBlanks:=True
Application.CutCopyMode = False
Else
ActiveCell.Offset(-1, 0).Select
End If
Loop
'Then delete rows that are not the "1st event row"
If Range("N23").Value > 0 Then
Range("A27:DS50000").Select
ActiveWorkbook.Worksheets("EventMerge").Sort.SortFields.add Key:=Range( _
"O27:O50000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveSheet.Range("$A$26:$DS$50000").AutoFilter Field:=15, Criteria1:="0"
Range("A27:A" & CStr(Range("BR16").Value + 26)).Select
Selection.ClearContents
Selection.EntireRow.Delete
Else
End If
If ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
Application.Calculation = xlAutomatic
Sheets("EventMerge").Range("BS6").Value = Now()
Range("BV5").Value = Range("BS7").Value
End Sub