Paste Data into table without overwriting data VBA-CodePudding

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

CodePudding user response：

Copy SpecialCells to Excel Tables

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.FilterMode Then sws.ShowAllData
    
    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

CodePudding user response：

The easiest way to solve this problem is to write a separate macro to handle copying and pasting the data to a table. In this way you can test your code independently of the main code.

If you just want to copy the values use PasteSpecial.

Sub PasteSpecialToNewRowsToTable(Table As ListObject, Source As Range, PasteType As XlPasteType)
    Rem Cancel the operation if the range contains no data
    If WorksheetFunction.CountA(Source) = 0 Then Exit Sub
    Dim ShowTotals As Boolean
    
    With Table
        ShowTotals = .ShowTotals
        .ShowTotals = False
        Source.Copy
        .HeaderRowRange.Offset(.ListRows.Count   1).Range("A1").PasteSpecial PasteType
        Table.ShowTotals = ShowTotals
    End With

End Sub

If you wanted to copy the values formulas and formats use Range.Copy Detsination.

Sub CopyRangeToNewListRow(Table As ListObject, Source As Range)
    Rem Cancel the operation if the range contains no data
    If WorksheetFunction.CountA(Source) = 0 Then Exit Sub
    Dim ShowTotals As Boolean
    
    With Table
        ShowTotals = .ShowTotals
        .ShowTotals = False
        Source.Copy .ListRows.Add.Range
        Table.ShowTotals = ShowTotals
    End With
End Sub

Usage

Sub FilterAndCopy()

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    Rem Paste Filtered Values to Table 2
    PasteSpecialToNewRowsToTable Table2, WHLocationsColumnHFilteredRange("C"), xlPasteValues
    
    Rem Copy Filtered Range to Table 3
    CopyRangeToNewListRow Table3, WHLocationsColumnHFilteredRange("D")
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic

End Sub

Public Property Get Table2() As ListObject
    Set Table2 = wsSummary.ListObjects("Table2")
End Property

Public Property Get Table3() As ListObject
    Set Table3 = wsWHLocations.ListObjects("Table3")
End Property

Public Function wsWHLocations() As Worksheet
    Set wsWHLocations = ThisWorkbook.Sheets("WH Locations")
End Function

Public Function wsSummary() As Worksheet
    Set wsWHLocations = ThisWorkbook.Sheets("Summary")
End Function

Public Function WHLocationsRange() As Range
    With wsWHLocations
        Set WHLocationsRange = .Range("A31", .Cells(.Rows.Count, "H").End(xlUp))
    End With
End Function

Public Function WHLocationsColumnHFilteredRange(FilterValue As Variant) As Range
    With WHLocationsRange
        .AutoFilter
        .AutoFilter Field:=8, Criteria1:=FilterValue
        Set WHLocationsColumnHFilteredRange = .Cells.Offset(1)
    End With
End Function

Sub PasteSpecialToNewRowsToTable(Table As ListObject, Source As Range, PasteType As XlPasteType)
    Rem Cancel the operation if the range contains no data
    If WorksheetFunction.CountA(Source) = 0 Then Exit Sub
    Dim ShowTotals As Boolean
        
    With Table
        ShowTotals = .ShowTotals
        .ShowTotals = False
        Source.Copy
        .HeaderRowRange.Offset(.ListRows.Count   1).Range("A1").PasteSpecial PasteType
        Table.ShowTotals = ShowTotals
    End With
    
End Sub
    
Sub CopyRangeToNewListRow(Table As ListObject, Source As Range)
    Rem Cancel the operation if the range contains no data
    If WorksheetFunction.CountA(Source) = 0 Then Exit Sub
    Dim ShowTotals As Boolean
        
    With Table
        ShowTotals = .ShowTotals
        .ShowTotals = False
        Source.Copy .ListRows.Add.Range
        Table.ShowTotals = ShowTotals
    End With
End Sub