Не копируются shape на другой лист

[Aleksandr H.]

Надо xls таблицу перевести в Pdf формат. Во вложении исходная таблица и ожидаемый Pdf-результат.
На данный момент, макрос не всегда копирует на новый лист объекты shape - копируются только на первой итерации.

использую .Select по совету https://stackoverflow.com/a/48620887/7725813

Как преобразовать исходную таблицу на другой лист в нужном виде из которого можно будет экспортировать в pdf?

Sub DoSomething()
    Dim oSheetInput As Worksheet
    Dim oSheetOutput As Worksheet
    Dim iCurrentDocument As Integer
    Dim iLastRowOutput As Integer
    Dim rngSelectionArea As Range
    Dim rngCopyingArea As Range
    
    Dim shape As Excel.shape
    
    Set oSheetInput = Sheets("1")
    Set oSheetOutput = Sheets("pdf")
    With oSheetOutput
        .Cells.ClearContents
        .Cells.ClearFormats
        .Columns(1).ColumnWidth = 65
        .Columns(2).ColumnWidth = 64
        For Each shape In .Shapes
            shape.Delete
        Next
    End With
    
    With oSheetInput
        If .AutoFilter.FilterMode Then
                .AutoFilter.ShowAllData
        End If
       
        Set rngSelectionArea = oSheetInput.Range("A13").CurrentRegion ' filtration range
        
        For iCurrentDocument = 2 To rngSelectionArea.Columns.Count
            ' filter non-empty rows of iCurrentDocument column
            rngSelectionArea.AutoFilter Field:=iCurrentDocument, Criteria1:="<>"
            
            ' sets Microsoft Excel to cut, copy, extract, and sort objects with cells.
            Application.CopyObjectsWithCells = True
             
            Set rngCopyingArea = .Range("A1").Resize(40, iCurrentDocument)
            
            rngCopyingArea.Copy
            
            ' 1st copy
            ' gets LastUsedRow of Output sheet
            iLastRowOutput = oSheetOutput.Cells(oSheetOutput.Rows.Count, "A").End(xlUp).Row + 1
            
            ' adds PageBreak in case of non first record
            If iLastRowOutput > 2 Then
                oSheetOutput.HPageBreaks.Add before:=oSheetOutput.Cells(iLastRowOutput, "A")
            End If
            oSheetOutput.Activate
            
            oSheetOutput.Cells(iLastRowOutput, "A").Select
            oSheetOutput.Paste
            
            ' 2nd copy
            ' gets LastUsedRow of Output sheet
            iLastRowOutput = oSheetOutput.Cells(oSheetOutput.Rows.Count, "A").End(xlUp).Row + 1
            
            ' adds PageBreak in case of non first record
            If iLastRowOutput > 2 Then
                oSheetOutput.HPageBreaks.Add before:=oSheetOutput.Cells(iLastRowOutput, "A")
            End If
            
            oSheetOutput.Cells(iLastRowOutput, "A").Activate
            oSheetOutput.Paste
            
            .Activate
            .Range("A1").Select
            
            ' hide performed column
            .Columns(iCurrentDocument).Hidden = True
            
            If .AutoFilter.FilterMode Then
                .AutoFilter.ShowAllData
            End If
            
            .Columns(iCurrentDocument + 1).ColumnWidth = 40
            
        Next iCurrentDocument
    End With
End Sub

[IgorGO]

Sub M1()
    ActiveSheet.Shapes.Range(Array("Group 1")).Select
    Selection.Copy
    Worksheets("pdf").Paste
End Sub