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

Sub each_table_into_new_document()
    'помещает каждую таблицу в отдельный документ
    Dim word_Doc As Word.Document
    Dim t As Table
    Dim p As String
    Dim i As Integer
    
    
    i =  1 
    For Each t In ThisDocument.Tables
                       
        t.Select
        Selection.Copy
        
        Set word_Doc = Application.Documents.Add(DocumentType:=wdNewBlankDocument)
        Selection.PasteAndFormat (wdPasteDefault)
        
        If i <  10  Then
            p = "0" & CStr(i)
        Else
            p = CStr(i)
        End If

        word_Doc.SaveAs "C:\Tables-" & p & ".doc"
        
        word_Doc.Close
        Set word_Doc = Nothing
        
        i = i +  1 
    Next
End Sub

Sub BreakOnPage_1()

Application.ScreenUpdating = False
 Application.Browser.Target = wdBrowsePage
 s = InputBox(Prompt:="Выберите номер страницы")
ActiveDocument.Bookmarks("\page").Range.Copy
 Documents.Add
Selection.Paste
Selection.TypeBackspace
ChangeFileOpenDirectory "D:\Мои документы\Новая папка"
DocNum = DocNum +  1 
ActiveDocument.SaveAs FileName:="test_" & DocNum & ".doc"
ActiveDocument.Close
Application.ScreenUpdating = True
End Sub

Sub BreakOnPage_1() 

Application.ScreenUpdating = False
 Application.Browser.Target = wdBrowsePage
 
 Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=InputBox(Prompt:="Выберите номер страницы")
 Selection.Find.ClearFormatting
 
ActiveDocument.Bookmarks("\page").Range.Copy
 Documents.Add
Selection.Paste
Selection.TypeBackspace
ChangeFileOpenDirectory "D:\Мои документы\Новая папка"
DocNum = DocNum +  1 
ActiveDocument.SaveAs FileName:="test_" & DocNum & ".doc"
ActiveDocument.Close
Application.ScreenUpdating = True
End Sub