excel - 将数据粘贴到表中而不覆盖数据 VBA

Question

我正在尝试从一张表中过滤数据并将过滤后的数据复制/粘贴到摘要表中。我有 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