Speed Up Macro - Autofilter Copying

[neodjandre]

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!

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

 

[mumps]

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.