将数据粘贴到 table 而不覆盖数据 VBA

Question

我正在尝试从一个 sheet 和 copy/paste 中过滤数据，后者将数据过滤到摘要 sheet 中。我有 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

Answer 1

将 SpecialCells 复制到 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.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

Answer 2

解决此问题的最简单方法是编写一个单独的宏来处理将数据复制和粘贴到 table。这样你就可以独立于主代码测试你的代码。

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

将数据粘贴到 table 而不覆盖数据 VBA

Paste Data into table without overwriting data VBA

excel

vba

autofilter

listobject

excel-tables

将 SpecialCells 复制到 Excel 表

用法