Option Explicit

Option Explicit

Sub SplitIntoPages()
Dim docMultiple As Document
Dim docSingle As Document
Dim rngPage As Range
Dim iCurrentPage As Integer
Dim iPageCount As Integer
Dim strNewFileName As String
Application.ScreenUpdating = False 'Делает код работать быстрее и уменьшает мерцание экрана немного.
Set docMultiple = ActiveDocument 'Работа с активным документом(тот, который в настоящее время содержит выделение)
Set rngPage = docMultiple.Range 'Создать экземпляр объекта range
iCurrentPage = 1
'Получить количество страниц документа
iPageCount = docMultiple.Content.ComputeStatistics(wdStatisticPages)
Do Until iCurrentPage > iPageCount
If iCurrentPage = iPageCount Then
rngPage.End = ActiveDocument.Range.End 'Последняя страница (следующей страницы не будет)
Else
'Найдите начало следующей страницы
'Необходимо использовать объект выбора. Range. Метод goto не будет работать на странице
Selection.GoTo wdGoToPage, wdGoToAbsolute, iCurrentPage + 1
'Установите конец диапазона в точку между страницами
rngPage.End = Selection.Start
End If
rngPage.Copy 'Копировать страницу в буфер обмена Windows
Set docSingle = Documents.Add 'создание нового документа
docSingle.Range.Paste 'вставьте содержимое буфера обмена в новый документ
'Eдалите любой разрыв страницы вручную, чтобы предотвратить второй пробел
docSingle.Range.Find.Execute Findtext:="^m", ReplaceWith:=""
'Создайте новое последовательно пронумерованное имя файла на основе исходного многостраничного имени файла и пути к нему
strNewFileName = Replace(docMultiple.FullName, ".rtf", "_" & Right$("000" & iCurrentPage, 4) & ".rtf")
docSingle.SaveAs strNewFileName 'Сохраните новый одностраничный документ
iCurrentPage = iCurrentPage + 1 'Перейти на следующую страницу
docSingle.Close 'Закройте новый документ
rngPage.Collapse wdCollapseEnd 'Перейти на следующую страницу
Loop 'Перейти к началу цикла do
Application.ScreenUpdating = True 'Восстановление обновления экрана
'Уничтожьте объекты.
Set docMultiple = Nothing
Set docSingle = Nothing
Set rngPage = Nothing
End Sub