How to copy and paste a filtered range more efficiently

Question

I have this bit of code that works for copy and pasting an autofiltered range. I just wanted to see if anyone knew a more efficient way to do so as it does take quite a while to complete it the way I have it now. I looked into trying to do so with a copying into an array but did not seem to work so I'm happy to hear some of your suggestions! Also I have to be sure that the range I am copying and pasting is not the full data range and only the range after the filter was applied.

Sub FullWork()

Dim shWorkBook As Worksheet
Dim shPivotTable As Worksheet
Dim shCarrierRates As Worksheet
Dim shWholesaleLocation As Worksheet
Dim shPWLocation As Worksheet
Dim wkb As Workbook
Dim shSegmentation As Worksheet
Dim MilageMatrix As Worksheet
Dim FullYearData As Worksheet
Dim StartForm As Worksheet
Set wkb = ThisWorkbook
With wkb

Set shWorkBook = .Sheets("Workbook")
Set shPivotTable = .Sheets("PivotTable")
Set shCarrierRates = .Sheets("CarrierRates")
Set shWholesaleLocation = .Sheets("WholesalerLocation")
Set shPWLocation = .Sheets("PWLocation")
Set shSegmentation = .Sheets("Segmentation")
Set shMilageMatrix = .Sheets("MilageMatrix")
Set shFullYearData = .Sheets("FullYearData")
Set shStartForm = .Sheets("StartForm")

End With

Dim DataRange As Range
Dim PWSelection As Variant
Dim LastRow As Long
Dim LastColumn As Long
Dim LocationZip As Variant
Dim dTime As Double

dTime = Timer

Call TurnOffCalc

Set StartCell = shFullYearData.Range("A1")

'Find Last Row and Column

LastRow = shFullYearData.Cells(shFullYearData.Rows.Count, StartCell.Column).End(xlUp).Row
LastColumn = shFullYearData.Cells(StartCell.Row, shFullYearData.Columns.Count).End(xlToLeft).Column

shFullYearData.Activate
shFullYearData.Range(StartCell, shFullYearData.Cells(LastRow, LastColumn)).Select

PWSelection = shStartForm.Cells(1, 1).Value

shFullYearData.Range(shFullYearData.Cells(1, 1), shFullYearData.Cells(1, LastColumn)).AutoFilter
If PWSelection <> "All" Then
shFullYearData.Range(StartCell, shFullYearData.Cells(LastRow, LastColumn)).AutoFilter Field:=12,         Criteria1:=PWSelection
End If
shFullYearData.Range(StartCell, shFullYearData.Cells(LastRow, LastColumn)).AutoFilter Field:=26, Criteria1:=">=1"
shFullYearData.Range(StartCell, shFullYearData.Cells(LastRow, LastColumn)).AutoFilter Field:=3, Operator:= _
xlFilterValues, Criteria2:=Array(0, "12/31/2019")
shFullYearData.Range(StartCell, shFullYearData.Cells(LastRow, LastColumn)).Sort Key1:=Range("G1"), Order1:=xlAscending, Header:=xlYes, Key2:=Range("B1"), Header:=xlYes

''''''Line I need looked at
shFullYearData.Range(StartCell, shFullYearData.Cells(LastRow, LastColumn)).Copy Destination:=shWorkBook.Range("A1")

call TurnOnCalc
end sub

Answer 1

The code as you have it is not able to be executed but once I made some revisions it seems to run just fine. On my test dataset I had no problem with performance, but if you continue to have performance issues after making edits, I would look into something called "Advanced Filter" for Excel, as it has the ability to set a destination at the onset for the filtered data to appear. You can simply look up "Advanced Filter" on your favorite search engine and find links like these, there are hundreds to pick from:

• https://www.thespreadsheetguru.com/blog/2015/2/16/advanced-filters-with-vba-to-automate-filtering-on-and-out-specific-values
• https://www.youtube.com/watch?v=0YNhxVu2a5s

As for my revisions to your code, see below. I've tried to comment every line I changed and change the minimum amount of lines possible.

Option Explicit

Sub FullWork()

Dim rngFullYearData  ' added to be able to reference easier later
'Dim DataRange As Range ' moved to keep all Dim statements together  ' commented out because it was not being used
Dim StartCell As Range  ' added to be able to Set later
Dim PWSelection As Variant
Dim LastRow As Long
Dim LastColumn As Long
'Dim LocationZip As Variant  ' commented out because it was not being used
'Dim dTime As Double  ' commented out because it was not being used

Dim shWorkBook As Worksheet
'Dim shPivotTable As Worksheet  ' commented out because it was not being used
'Dim shCarrierRates As Worksheet  ' commented out because it was not being used
'Dim shWholesaleLocation As Worksheet  ' commented out because it was not being used
'Dim shPWLocation As Worksheet  ' commented out because it was not being used
'Dim shSegmentation As Worksheet  ' commented out because it was not being used
Dim wkb As Workbook
'Dim shMilageMatrix As Worksheet  ' added sh to beginning to stay consistent  ' commented out because it was not being used
Dim shFullYearData As Worksheet  ' added sh to beginning to stay consistent
Dim shStartForm As Worksheet  ' added sh to beginning to stay consistent

Set wkb = ThisWorkbook
With wkb  ' indenting with block for ease of readability
    Set shWorkBook = .Sheets("Workbook")
    'Set shPivotTable = .Sheets("PivotTable")  ' commented out because it was not being used
    'Set shCarrierRates = .Sheets("CarrierRates")  ' commented out because it was not being used
    'Set shWholesaleLocation = .Sheets("WholesalerLocation")  ' commented out because it was not being used
    'Set shPWLocation = .Sheets("PWLocation")  ' commented out because it was not being used
    'Set shSegmentation = .Sheets("Segmentation")  ' commented out because it was not being used
    'Set shMilageMatrix = .Sheets("MilageMatrix")  ' commented out because it was not being used
    Set shFullYearData = .Sheets("FullYearData")
    Set shStartForm = .Sheets("StartForm")
End With

'dTime = Timer  ' commented out because it was not being used

'Call TurnOffCalc  ' commenting out because sub was not included

Set StartCell = shFullYearData.Range("A1")

'Find Last Row and Column

LastRow = shFullYearData.Cells(shFullYearData.Rows.Count, StartCell.Column).End(xlUp).Row
LastColumn = shFullYearData.Cells(StartCell.Row, shFullYearData.Columns.Count).End(xlToLeft).Column

'shFullYearData.Activate  ' no need to activate if not selecting below
Set rngFullYearData = shFullYearData.Range(StartCell, shFullYearData.Cells(LastRow, LastColumn))  ' remove select, add set instead

PWSelection = shStartForm.Cells(1, 1).Value

With rngFullYearData ' simplify with new variable, add with block for easier referencing
    .AutoFilter
    If PWSelection <> "All" Then
        .AutoFilter Field:=12, Criteria1:=PWSelection  ' using new variable
    End If
    .AutoFilter Field:=26, Criteria1:=">=1"  ' using new variable
    .AutoFilter Field:=3, Operator:= _
    xlFilterValues, Criteria2:=Array(0, "12/31/2019")  ' using new variable
    .Sort Key1:=Range("G1"), Order1:=xlAscending, Header:=xlYes, Key2:=Range("B1"), Header:=xlYes

''''''Line I need looked at
    .Copy Destination:=shWorkBook.Range("A1")  ' using new variable
End With

'Call TurnOnCalc  ' commenting out because sub was not included

' release variables when finished with them
Set wkb = Nothing
Set rngFullYearData = Nothing
Set shWorkBook = Nothing
'Set shPivotTable = Nothing  ' only including as a reminder in case you use this worksheet later
'Set shCarrierRates = Nothing
'Set shWholesaleLocation = Nothing
'Set shPWLocation = Nothing
'Set shSegmentation = Nothing
'Set shMilageMatrix = Nothing
Set shFullYearData = Nothing
Set shStartForm = Nothing
Set StartCell = Nothing
End Sub
```