Macro runs too slow - Any alternatives

[neodjandre]

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

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

 

[Fazza]

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.

 

[Fazza]

Just guessing: maybe this line is slow too? arr = Application.Index(arr, aRws, Array(15, 1, 6, 2, 13, 12, 17, 21, 7))