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 & ".rtf"
    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 & ".rtf").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

Option Explicit

Dim Path, FSO, NameFile, wb, fil, curfold, objEX

'определяем каталог, в котором находимся
Set FSO = CreateObject("Scripting.FileSystemObject")

'сохраняем путь, в котором находимся
Path = FSO.GetParentFolderName(WScript.ScriptFullName)
Set curfold = FSO.GetFolder(Path)

'находим файл .rtf в каталоге и открываем.
If Not curfold Is Nothing Then
For Each fil In curfold.Files
If InStr(1, fil.Name, ".rtf", vbTextCompare) > 0 and (InStr(1, fil.Name, "*(*)*", vbTextCompare) > 0 ) Then
NameFile = fil.Name

Set wb = objEX.Workbooks.Open(Path & "\" & NameFile)

wb.Close False
end if

Next
End If
Set FSO = Nothing