部分粘贴小计数据

Question

我正在尝试将小写的可见范围粘贴到另一个工作表。我使用的代码省略了最后几行。有人可以引导我在我之后的代码中弄错，使我能够将图像中阴影的最后几行粘贴到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是here

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