I am trying to filter data from one sheet and copy/paste that filtered data over into a summary sheet. I have 2 criteria that, if met, need to go into two separate summary tables. I am able to get the data filtered and copied, however, when it pastes into the respective tables, it is overwriting the total row at the bottom of the tables.
I need the data that is copied to go into the bottom of the tables, but above the last row so that the total rows are not affected.
Option Explicit
Sub FilterAndCopy()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim lngLastRow As Long
Dim col As Integer
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Sheets("WH Locations")
Set ws2 = Sheets("Summary")
lngLastRow = ws1.Cells(Rows.Count, "H").End(xlUp).Row
With Range("A31", "H" & lngLastRow)
.AutoFilter
.AutoFilter Field:=8, Criteria1:="C"
.Offset(1, 0).Resize(.Rows.Count - 1).Copy Destination:=ws2.ListObjects("Table2")
.AutoFilter Field:=8, Criteria1:="D"
.Offset(1, 0).Resize(.Rows.Count - 1).Copy Destination:=ws2.ListObjects("Table3")
.AutoFilter
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
Option Explicit
Sub FilterAndCopy()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets("WH Locations")
If sws.AutoFilterMode Then sws.AutoFilterMode = False ' turn off AutoFilter
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "H").End(xlUp).Row
Dim srg As Range: Set srg = sws.Range("A31", "H" & slRow)
Dim sdrg As Range: Set sdrg = srg.Resize(srg.Rows.Count - 1).Offset(1)
Dim sdcrg As Range: Set sdcrg = sdrg.Columns(1)
Dim dws As Worksheet: Set dws = wb.Worksheets("Summary")
Dim srCount As Long
Dim drCount As Long
Dim dtbl2 As ListObject: Set dtbl2 = dws.ListObjects("Table2")
If dtbl2.AutoFilter.FilterMode Then dtbl2.AutoFilter.ShowAllData
srg.AutoFilter Field:=8, Criteria1:="C"
On Error Resume Next
srCount = sdcrg.SpecialCells(xlCellTypeVisible).Cells.Count
On Error GoTo 0
If srCount > 0 Then
dtbl2.ShowTotals = False
drCount = dtbl2.Range.Rows.Count
dtbl2.Resize dtbl2.Range.Resize(drCount + srCount)
sdrg.SpecialCells(xlCellTypeVisible).Copy dtbl2.Range.Rows(drCount + 1)
dtbl2.ShowTotals = True
srCount = 0
End If
Dim dtbl3 As ListObject: Set dtbl3 = dws.ListObjects("Table3")
If dtbl3.AutoFilter.FilterMode Then dtbl3.AutoFilter.ShowAllData
srg.AutoFilter Field:=8, Criteria1:="D"
On Error Resume Next
srCount = sdcrg.SpecialCells(xlCellTypeVisible).Cells.Count
On Error GoTo 0
If srCount > 0 Then
dtbl3.ShowTotals = False
drCount = dtbl3.Range.Rows.Count
dtbl3.Resize dtbl3.Range.Resize(drCount + srCount)
sdrg.SpecialCells(xlCellTypeVisible).Copy dtbl3.Range.Rows(drCount + 1)
dtbl3.ShowTotals = True
'srCount = 0
End If
sws.ShowAllData
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub