Speed Up Macro - Autofilter Copying

neodjandre

Well-known Member
Joined
Nov 29, 2006
Messages
950
Office Version
  1. 2019
Platform
  1. 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!

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
 

Excel Facts

Show numbers in thousands?
Use a custom number format of #,##0,K. Each comma after the final 0 will divide the displayed number by another thousand
Rather than trying to decipher your code, perhaps you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Include a detailed explanation of what you would like to do using a few examples from your data and referring to specific cells, rows, columns and worksheets. If the workbook contains confidential information, you could replace it with generic data.
 
Upvote 0

Forum statistics

Threads
1,223,228
Messages
6,170,875
Members
452,363
Latest member
merico17

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top