部分粘贴的subtotaled数据

我正在尝试将一个小计的可见范围粘贴到另一张纸上。 我使用的代码是省略了最后几行。 有人可能会指导我在代码后面错误地使我能够将图像中阴影最后几行粘贴到Sheet2。

后面的代码如下

Sub CopySubtotaledRange() Dim src As Worksheet Dim tgt As Worksheet Dim SubtotalRange As Range Dim copyRange As Range Dim lastRow As Long Set src = ThisWorkbook.Sheets("Sheet1") Set tgt = ThisWorkbook.Sheets("Sheet2") ' find the last row with data in column A lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row ' the range that we are Subtotaling (all columns) Set SubtotalRange = src.Range("A1:G" & lastRow) ' the range we want to copy Set copyRange = src.Range("A1:G" & lastRow) ' Subttotal range grouped on column B and totals based on column E and F SubtotalRange.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(5, 6), _ Replace:=True, PageBreaks:=False, SummaryBelowData:=True ActiveSheet.Outline.ShowLevels RowLevels:=2 ' copy the visible cells to our target range copyRange.SpecialCells(xlCellTypeVisible).Copy tgt.Range("A1") End Sub 

文件tryme1.xlsm在这里

Answer 1

尝试下面的代码。 您的lastRow calc对于copyRange不正确，因为它在添加小计之前计算。

 Sub CopySubtotaledRange() Dim src As Worksheet Dim tgt As Worksheet Dim SubtotalRange As Range Dim copyRange As Range Dim lastRow As Long Set src = ThisWorkbook.Sheets("Sheet1") Set tgt = ThisWorkbook.Sheets("Sheet2") ' find the last row with data in column A lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row ' the range that we are Subtotaling (all columns) Set SubtotalRange = src.Range("A1:G" & lastRow) ' Subttotal range grouped on column B and totals based on column E and F SubtotalRange.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(5, 6), _ Replace:=True, PageBreaks:=False, SummaryBelowData:=True ActiveSheet.Outline.ShowLevels RowLevels:=2 lastRow = Range("B1").End(xlDown).Row ' the range we want to copy Set copyRange = src.Range("A1:G" & lastRow) ' copy the visible cells to our target range copyRange.SpecialCells(xlCellTypeVisible).Copy tgt.Range("A1") End Sub