Copy/paste Filtered range into table VBA

[Tdorman]

Hello,

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 of the tables 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

 

[John_w]

I need the data that is copied to go into the bottom of the tables, but above the last row of the tables so that the total rows are not affected.

Do you mean the data should be copied to the tables, above the total row and below existing data rows? If so, try this:

ub 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
    Dim numVisibleRows As Long
    Dim table As ListObject
    
    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"
        numVisibleRows = .Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
        Set table = ws2.ListObjects("Table2")        
        table.Resize table.Range.Resize(table.Range.Rows.Count + numVisibleRows)
        .Offset(1, 0).Resize(.Rows.Count - 1).Copy Destination:=table.DataBodyRange.Rows(table.DataBodyRange.Rows.Count + 1 - numVisibleRows)
        
        .AutoFilter Field:=8, Criteria1:="D"
        numVisibleRows = .Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
        Set table = ws2.ListObjects("Table3")
        table.Resize table.Range.Resize(table.Range.Rows.Count + numVisibleRows)
        .Offset(1, 0).Resize(.Rows.Count - 1).Copy Destination:=table.DataBodyRange.Rows(table.DataBodyRange.Rows.Count + 1 - numVisibleRows)
        
        .AutoFilter
    End With
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic

End Sub

 

[Tdorman]

Thank you for your help!

Yes that's what I'm trying to achieve. I am getting an error at

table.Resize table.Range.Resize(table.Range.Rows.Count + numVisibleRows)

It says Cannot complete operation: A table cannot overlap with a PivotTable report, query results, a table, merged cells, or an xml mapping. I had table 3 below table 2 and also tried moving table 3 to the side of table 2, however, I still received the same error message.

 

[John_w]

I would need a sample workbook to investigate that error and change the code. If you want to, upload a workbook which reproduces the error to a file sharing site and post the link here.