将数据粘贴到表中而不覆盖数据 VBA答案

【问题标题】：Paste Data into table without overwriting data VBA将数据粘贴到表中而不覆盖数据 VBA
【发布时间】：2023-02-02 05:19:28
【问题描述】：

我正在尝试从一张表中过滤数据并将过滤后的数据复制/粘贴到摘要表中。我有 2 个标准，如果满足，需要进入两个单独的汇总表。我能够过滤和复制数据，但是，当它粘贴到相应的表中时，它会覆盖表底部的总行。

我需要将复制的数据放入表的底部，但在最后一行上方，以便不影响总行数。

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

【问题讨论】：

标签： excel vba autofilter listobject excel-tables

【解决方案1】：

将特殊单元格复制到 Excel 表格

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

【讨论】：

感谢您的帮助，效果很好！我为相应表格中的每一列添加了总计，一切正常，再次感谢。
快速提问，如果我第二次运行宏，我将如何做到只有新条目才会从 WH Locations 表中提取到 Summary Sheet？ WH Locations 的 A 列有一个唯一的标识符，我可以用它来检查并确保它不在汇总表的枯萎表中。
在源工作表中，添加另一列，您将在其中标记每个复制的行，例如Yes。过滤时，使用 2 个过滤器，例如"C"在一列（运算符设置为xlAnd）和"="（空白）在这个新列中，在复制之前，为所有可见单元格写入Yes。自己试试吧。如果您遇到困难，您可以随时提出另一个问题。

【解决方案2】：

解决这个问题最简单的方法是编写一个单独的宏来处理将数据复制和粘贴到表中。通过这种方式，您可以独立于主代码测试您的代码。

如果您只想复制值，请使用 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

如果您想复制值公式和格式，请使用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

用法

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

【讨论】：