Speed Up Excel Macro - Autofilter Copying

Question

I am using this code which works fine, but runs painfully slow.

The code filters an Excel Table and then extracts only certain columns and pastes them into another sheet (in a different order).

Could it be sped up perhaps with a multi-dimensional array?

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

Answer 1

Turn on Option Explicit from the menu via Tools>Options>Editor tab>Require Variable Declaration. This mandates you Dim lastRow as long before using it anywhere. Doing this will save you needless frustration later down the line when you transpose a variable name raom instead of roam and time's wasted till you find it.

If you have two Ranges that are same size and you want to copy the values over you can do Foo.Value2 = Bar.Value2 to achieve this without any copying. If you have a Range that is the same size as an array you get the same with Foo.Value2 = inMemoryArray`.

Use descriptive variable names. x_bf1 doesn't have any meaning, at least to me. If future-you comes back to this code and doesn't know what it means you'll be wishing past-you had used a descriptive name. An example of this being useful is the comments 'Date in two locations. Renaming copyrange1 to dateArea will cause these comments to become redundant and removable as your code is self documenting already describing what it is doing, save comments for why.

Set copyrange1 = x_bf1.Range("D8:D" & lastrow_s) 'Date
...
copyrange1.SpecialCells(xlCellTypeVisible).Copy 'Date
pasterange1.Offset(0, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone

becomes

destinationArea.Offset(0, 1).Value2 = dateArea.Value2

Tied to naming is the use of _ underscore. If you end up using interfaces be aware that this is how interface implementation is done. Double click on your first worksheet then at the dropdowns at the top select Worksheet from the left dropdown, and SelectionChange from the right dropdown. You get Private Sub Worksheet_SelectionChange(ByVal Target As Range) which is an example of the underscore used this way.

You turn off ScreetUpdating and the rest, but it's never turned back on in your provided code. Make sure that is restored.

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
    .EnableEvents = False
End With

You're using a named range from a workbook. Every usage of them includes RefersToRange(1, 1). If your names are single cell Ranges this is redundant.

---

Refactored Code.

Public Sub Refactor()
    Dim x_bf1 As Worksheet
    Dim lo_b1 As ListObject
    Set lo_b1 = x_bf1.ListObjects(1)
    Dim s_date As Long
    s_date = CLng(ThisWorkbook.Names("in_fre_m").RefersToRange(1, 1))
    Dim s_des As Range
    s_des = ThisWorkbook.Names("dr_no").RefersToRange(1, 1)
    Dim s_code As Range
    s_code = ThisWorkbook.Names("dr_co").RefersToRange(1, 1)
    Dim lastrow_d As Long
    Dim lo_dr As ListObject
    lastrow_d = lo_dr.Range.Columns(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1

    With lo_b1.Range
        .AutoFilter Field:=13, Criteria1:=s_code
        .AutoFilter Field:=1, Criteria1:="<=" & s_date
    End With

    Dim lastrow_s As Long
    lastrow_s = lo_b1.Range.Columns(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

    If lastrow_s > 7 Then
        Dim dateArea As Range
        Set dateArea = x_bf1.Range("D8:D" & lastrow_s)
        Dim description As Range
        Set description = dateArea.Offset(0, 1)
        Dim calculationArea As Range
        Set calculationArea = dateArea.Offset(0, 16)
        Dim classification As Range
        Set classification = dateArea.Offset(0, 5)
        Dim notes As Range
        Set notes = dateArea.Offset(0, 6)
        Dim parragraph As Range
        Set parragraph = dateArea.Offset(0, 11)
        Dim code As Range
        Set code = dateArea.Offset(0, 12)
        Dim statutory As Range
        Set statutory = dateArea.Offset(0, 20)
        Dim reference As Range
        Set reference = dateArea.Offset(0, 14)

        Dim x_drill As Worksheet
        Dim destinationArea As Range
        Set destinationArea = x_drill.Range("C" & lastrow_d).Resize(dateArea.Rows.Count, 9)

        Dim singlePopulationHelper() As String
        singlePopulationHelper = LoadHelperArraywWithValues(reference, _
                                                            dateArea, _
                                                            classification, _
                                                            description, _
                                                            code, _
                                                            parragraph, _
                                                            calculationArea, _
                                                            statutory, _
                                                            notes)
        destinationArea.Value2 = singlePopulationHelper
    End If
End Sub

Private Function LoadHelperArraywWithValues(ParamArray values()) As String()
    Dim rowCount As Long
    rowCount = values(0).SpecialCells(xlCellTypeVisible).Cells.Count
    Dim columnCount As Long
    columnCount = UBound(values)
    Dim helperArray() As String
    ReDim helperArray(rowCount, columnCount)

    Dim populationColumn As Long
    For populationColumn = 0 To columnCount
        Dim workingColumn As Range
        Set workingColumn = values(populationColumn)
        Dim populationRow As Long
        populationRow = 0
        Dim subArea As Range
        For Each subArea In workingColumn.SpecialCells(xlCellTypeVisible).Areas
            Dim cell As Range
            For Each cell In subArea
                helperArray(populationRow, populationColumn) = cell.Value2
                populationRow = populationRow + 1
            Next
        Next
    Next
    LoadHelperArraywWithValues = helperArray
End Function

Alternate copying to temporary worksheet.

Private Function CopyToTempSheetBeforeLoading(ParamArray values()) As Variant
    Dim populatedColumns As Long

    Dim tempSheet As Worksheet
    Set tempSheet = ThisWorkbook.Worksheets.Add

    For populatedColumns = 0 To UBound(values)
        values(populatedColumns).SpecialCells(xlCellTypeVisible).Copy
        tempSheet.Range("B2").Offset(ColumnOffset:=populatedColumns).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
    Next
    CopyToTempSheetBeforeLoading = tempSheet.Range("B2").CurrentRegion
    tempSheet.Delete
End Function
```

Answer 2

Answering my own question, this might even run quicker than accepted solution:

If lastrow_s > 7 Then

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(14, 1, 6, 2, 13, 12, 18, 16, 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
End If

What this does:

1. copies the auto-filtered range to a temp location
2. an array is created from the temp data
3. the array is evaluated and only columns of interest are maintained in preferred order
4. the array is pasted in desired location

The only problem I am having is that dates are pasted as text, and cannot be filtered as dates in new location. If you have any ideas on how to fix that without looping please let me know.