我正在嘗試從一張表中過濾資料并將過濾后的資料復制/粘貼到摘要表中。我有 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
uj5u.com熱心網友回復：
將 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
uj5u.com熱心網友回復：
解決此問題的最簡單方法是撰寫一個單獨的宏來處理將資料復制和粘貼到表中。通過這種方式，您可以獨立于主代碼測驗您的代碼。
如果您只想復制值，請使用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
轉載請註明出處，本文鏈接：https://www.uj5u.com/net/433510.html