Sub each_sheet_into_new_document()
'помещает каждый лист в отдельный документ
Dim word_App As New Word.Application
Dim word_Doc As Word.Document
Dim word_Shape As Shape
Selection.HomeKey Unit:=wdStory

pages_count = ActiveDocument.Range.ComputeStatistics(wdStatisticPages)
For i =  1  To pages_count
    Set word_Doc = word_App.Documents.Add
    With word_Doc
    If i = pages_count Then
        Selection.EndKey Unit:=wdStory, Extend:=wdExtend
    Else
        Selection.ExtendMode = True
        Selection.GoToNext wdGoToPage
        Selection.MoveLeft wdCharacter,  1 , False
                
    End If
        text_for_input = Selection
        Selection.ExtendMode = False
        Selection.MoveRight wdCharacter,  2 , False
        .StoryRanges(wdMainTextStory) = text_for_input
        word_App.Visible = True

        
        If i <  10  Then
            p = "0" & i
        Else
            p = i
        End If
        
        .SaveAs "C:\Лист-" & p & ".doc"
    End With
Next i

'этот кусок кода переносит shapes в новый документ
        For Each word_Shape In ActiveDocument.Shapes
            'MsgBox ActiveDocument.Shapes.Count
            word_Shape.Select
            p = Selection.Information(wdActiveEndPageNumber)
            If p <  10  Then
                p = "0" & Selection.Information(wdActiveEndPageNumber)
            End If
            Selection.Copy
            word_App.Documents("Лист-" & p & ".doc").Activate
            word_App.Selection.Paste
        Next word_Shape
        
        For Each doc In word_App.Documents
            doc.Save
        Next doc

Set word_App = Nothing
End Sub