将特殊单元格复制到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

解决这个问题最简单的方法是编写一个单独的宏来处理将数据复制和粘贴到表中的操作。这样，您就可以独立于主代码来测试代码。
如果只想复制值，请使用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