Макрос для разделения файла на нескольо по страницам

    Private Declare Function timeGetTime Lib "winmm.dll" () As Long
    Private Declare Function timeBeginPeriod Lib "winmm.dll" (ByVal uPeriod As Long) As Long
    Private Declare Function timeEndPeriod Lib "winmm.dll" (ByVal uPeriod As Long) As Long
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'Сохранение каждой страницы в отдельный документ
 Sub SaveEachPageToFileM()
   Dim oRng As Range, oMainDoc As Document, oNewDoc As Document, sFileName$, iPage As Long, cntp As Long
   
   Dim tm As Long, tmu As Long
   timeBeginPeriod 1
   Sleep 20
   tm = timeGetTime()
   
   Application.ScreenUpdating = False  'Отключаем обновление экрана
   
   Set oMainDoc = ActiveDocument
   Set oRng = oMainDoc.Range           'Диапазон основного документа
   cntp = oMainDoc.ComputeStatistics(2) ' Количество страниц в документе
   Set oNewDoc = Documents.Add
   
   Do
     iPage = iPage + 1
     'Изменяем рабочий диапазон до одной страницы
     If iPage > 1 Then Set oRng = oRng.GoToNext(1)   'wdGoToPage

     If iPage < cntp Then
       oRng.SetRange oRng.Start, oRng.GoToNext(1).Start 'wdGoToPage
     Else
       oRng.SetRange oRng.Start, oMainDoc.Range.End
     End If

     'Копируем страницы
     oNewDoc.Content.Delete
     oRng.Copy
     oNewDoc.Content.Paste
     
     'Имя файла
     sFileName = "Страница " & iPage & " документа (" & Mid(oMainDoc.Name, 1, InStrRev(oMainDoc.Name, ".") - 1) & ")"
     'Сохраняем новый документ в папку с исходным
     oNewDoc.SaveAs oMainDoc.Path & Application.PathSeparator & sFileName & Mid(oMainDoc.Name, InStrRev(oMainDoc.Name, ".")), AddToRecentFiles:=False, FileFormat:=oMainDoc.SaveFormat
   Loop While iPage < cntp
   
   Set oRng = Nothing
   oNewDoc.Close wdDoNotSaveChanges
   Set oNewDoc = Nothing
   
   tm = timeGetTime() - tm
   timeEndPeriod 1
   'Включаем обновление экрана
   Application.ScreenUpdating = True
   
   MsgBox "Сохранено в файлы " & iPage & " страниц. Прошло " & CStr(tm / 1000) & " сек." & vbCr & _
         "Папка сохранения: " & oMainDoc.Path & Application.PathSeparator, vbOKOnly + vbInformation, "Документы сохранены"
   Set oMainDoc = Nothing
 End Sub