Частичное склеивание промежуточных данных

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