neodjandre
Well-known Member
- Joined
- Nov 29, 2006
- Messages
- 950
- Office Version
- 2019
- Platform
- Windows
I am using this code which works fine, but runs painfully slow.
What my code does is that it filters an Excel Table and then extracts only certain columns and pastes them into another sheet (in a different order).
Could it be speed up perhaps with a multi-dimensional array instead of copying and pasting ranges?
Any help would be much appreciated!
What my code does is that it filters an Excel Table and then extracts only certain columns and pastes them into another sheet (in a different order).
Could it be speed up perhaps with a multi-dimensional array instead of copying and pasting ranges?
Any help would be much appreciated!
Code:
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
.EnableEvents = False
End With
Set lo_b1 = x_bf1.ListObjects(1)
s_date = CLng(ThisWorkbook.Names("in_fre_m").RefersToRange(1, 1))
s_des = ThisWorkbook.Names("dr_no").RefersToRange(1, 1)
s_code = ThisWorkbook.Names("dr_co").RefersToRange(1, 1)
lastrow_d = lo_dr.Range.Columns(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
Set pasterange1 = x_drill.Range("C" & lastrow_d)
With lo_b1.Range
.AutoFilter Field:=13, Criteria1:=s_code
.AutoFilter Field:=1, Criteria1:="<=" & s_date
End With
lastrow_s = lo_b1.Range.Columns(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
If lastrow_s > 7 Then
Set copyrange1 = x_bf1.Range("D8:D" & lastrow_s) 'Date
Set copyrange2 = copyrange1.Offset(0, 1) 'Description
Set copyrange3 = copyrange1.Offset(0, 16) 'Calculation
Set copyrange5 = copyrange1.Offset(0, 5) 'Classification
Set copyrange6 = copyrange1.Offset(0, 6) 'Notes
Set copyrange7 = copyrange1.Offset(0, 11) '§
Set copyrange8 = copyrange1.Offset(0, 12) 'Code
Set copyrange9 = copyrange1.Offset(0, 20) 'Statutory
Set copyrange10 = copyrange1.Offset(0, 14) 'Ref
copyrange10.SpecialCells(xlCellTypeVisible).Copy 'Ref
pasterange1.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
copyrange1.SpecialCells(xlCellTypeVisible).Copy 'Date
pasterange1.Offset(0, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
copyrange5.SpecialCells(xlCellTypeVisible).Copy 'Account Name
pasterange1.Offset(0, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
copyrange2.SpecialCells(xlCellTypeVisible).Copy 'Notes
pasterange1.Offset(0, 3).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
copyrange8.SpecialCells(xlCellTypeVisible).Copy 'Code
pasterange1.Offset(0, 4).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
copyrange7.SpecialCells(xlCellTypeVisible).Copy '§
pasterange1.Offset(0, 5).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
copyrange3.SpecialCells(xlCellTypeVisible).Copy 'Calculation
pasterange1.Offset(0, 6).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
copyrange9.SpecialCells(xlCellTypeVisible).Copy 'Statutory
pasterange1.Offset(0, 7).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
copyrange6.SpecialCells(xlCellTypeVisible).Copy 'Notes
pasterange1.Offset(0, 8).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
Set copyrange1 = Nothing
Set copyrange2 = Nothing
Set copyrange3 = Nothing
Set copyrange4 = Nothing
Set copyrange5 = Nothing
Set copyrange6 = Nothing
Set copyrange7 = Nothing
Set copyrange8 = Nothing
Set copyrange9 = Nothing
Set copyrange10 = Nothing
End If