Macro runs too slow - Any alternatives

neodjandre

Well-known Member
Joined
Nov 29, 2006
Messages
926
I have tried to optimise my macro as much as possible but still it takes over 30-60 seconds to execute for 2,000 entries. This is very poor performance and I was wondering if I can use any alternatives (including third party plugins?). This is my final code and it does the following:
1. Autofilters a table based on criteria
2. copies the filtered data to a temp sheet
3. assigns the data to an array
4. manipulates the data in the array
5. pastes the data to specified sheet

many thanks, Andrew

Code:
Sub TestRun()
Dim s_type As String
Dim s_des As String
Dim s_code As String
Dim e_date As String
Dim s_date As String
Dim strng As Range
Dim copyrng As Range
Dim arr As Variant
Dim aRws As Variant
Dim lo_b1 As ListObject
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
 
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
.EnableEvents = False
End With

Set lo_b1 = x_bf1.ListObjects(1)

s_date = CLng(ThisWorkbook.Names("drd_sta").RefersToRange(1, 1))
e_date = CLng(ThisWorkbook.Names("drd_end").RefersToRange(1, 1))
s_des = ThisWorkbook.Names("drill_account").RefersToRange(1, 1)
s_code = ThisWorkbook.Names("dr_co").RefersToRange(1, 1)
s_type = ThisWorkbook.Names("dr_le").RefersToRange(1, 1)

With lo_b1.Range
    .AutoFilter Field:=13, Criteria1:=s_code
    .AutoFilter Field:=1, Criteria1:=">=" & s_date, Operator:=xlAnd, Criteria2:="<=" & e_date
End With
         
Set strng = ThisWorkbook.Names("co_st").RefersToRange.Offset(1, 0)

Set copyrng = lo_b1.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
copyrng.Copy Destination:=strng

arr = strng.CurrentRegion.Offset(1, 0)
aRws = Evaluate("Row(1:" & UBound(arr) & ")")
arr = Application.Index(arr, aRws, Array(15, 1, 6, 2, 13, 12, 17, 21, 7))
  
With strng.CurrentRegion
.ClearContents
.Interior.Color = xlNone
.Borders.LineStyle = xlNone
End With

pasterange1.Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr

Set copyrng = Nothing
Erase arr
Erase aRws
lo_b1.AutoFilter.ShowAllData

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
.StatusBar = False
End With

SecondsElapsed = Round(Timer - StartTime, 2)
Debug.Print SecondsElapsed
'Debug.Print ArrayLen(arr)
End Sub
 
Last edited:

Some videos you may like

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.

Fazza

MrExcel MVP
Joined
May 17, 2006
Messages
9,368
From a quick look, the only thing that jumps out is the use of special cells for copying visible cells. This can be a slow step.

To identify the slow part of the code you can add plenty of debug.print steps within the code and see the time elapsed at different points. For example, if the step I identified is slow, you'll see most other steps happen in a second or whatever & the copying of visible cells might be 20 seconds. (Next sentence added as post script) And if possible this step can be much faster by sorting the data so that the range to be copied is contiguous.

Key to faster execution is the approach. Whatever optimisations can be done in code can be immaterial if the approach being used is not the fastest way.
 
Last edited:

Fazza

MrExcel MVP
Joined
May 17, 2006
Messages
9,368
Just guessing: maybe this line is slow too? arr = Application.Index(arr, aRws, Array(15, 1, 6, 2, 13, 12, 17, 21, 7))
 

Watch MrExcel Video

Forum statistics

Threads
1,102,737
Messages
5,488,575
Members
407,647
Latest member
powellku

This Week's Hot Topics

  • Timer in VBA - Stop, Start, Pause and Reset
    [CODE=vba][/CODE] Option Explicit Dim CmdStop As Boolean Dim Paused As Boolean Dim Start Dim TimerValue As Date Dim pausedTime As Date Sub...
  • how to updates multiple rows in muliselect listbox
    Hello everyone. I need help with below code. code is only chaning 1st row in mulitiselect list box. i know issue with code...
  • Delete Row from Table
    I am trying to delete a row from a table using VBA using a named range to find what I need to delete. My Range is finding the right cell. In the...
  • Assigning to a variable
    I have a for each block where I want to assign the value in column 5 of the found row to the variable Serv. [CODE=vba] For Each ws In...
  • Way to verify information
    Hi All, I don't know what to call this formula, and therefore can't search. I have a spreadsheet with information I want to reference...
  • Active Cell Address – Inactive Sheet
    How to use VBA to get the cell address of the active cell in an inactive worksheet and then place that cell address in a location on the current...
Top