neodjandre
Well-known Member
- Joined
- Nov 29, 2006
- Messages
- 950
- Office Version
- 2019
- Platform
- Windows
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
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: