макрос для Word файлу який перетворює кожен окремий аркуш на окремий файл

Sub SplitDocumentByPages()
Dim SourceDoc As Document
Dim NewDoc As Document
Dim PageNum As Integer
Dim TotalPages As Integer
Dim SavePath As String
Dim FileName As String
Dim OriginalName As String
Dim rng As Range

' Перевірка чи є відкритий документ
If Documents.Count = 0 Then
MsgBox "Будь ласка, відкрийте документ!", vbExclamation
Exit Sub
End If

Set SourceDoc = ActiveDocument

' Перевірка чи документ збережений
If SourceDoc.Path = "" Then
MsgBox "Спочатку збережіть документ!", vbExclamation
Exit Sub
End If

' Отримуємо шлях та ім'я файлу
SavePath = SourceDoc.Path & "\"
OriginalName = Left(SourceDoc.Name, InStrRev(SourceDoc.Name, ".") - 1)

' Оновлюємо кількість сторінок
SourceDoc.Repaginate
TotalPages = SourceDoc.ComputeStatistics(wdStatisticPages)

If TotalPages < 2 Then
MsgBox "Документ містить лише одну сторінку.", vbInformation
Exit Sub
End If

Application.ScreenUpdating = False

' Проходимо по кожній сторінці
For PageNum = 1 To TotalPages
' Переходимо на потрібну сторінку
Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=PageNum

' Виділяємо всю сторінку
Set rng = SourceDoc.Bookmarks("\Page").Range

' Створюємо новий документ
Set NewDoc = Documents.Add

' Копіюємо вміст сторінки
rng.Copy
NewDoc.Content.Paste

' Видаляємо зайвий розрив сторінки в кінці (якщо є)
With NewDoc.Content
If .Characters.Last.Previous.Text = Chr(12) Then
.Characters.Last.Previous.Delete
End If
End With

' Формуємо ім'я файлу
FileName = SavePath & OriginalName & "_Сторінка_" & Format(PageNum, "000") & ".docx"

' Зберігаємо новий документ
NewDoc.SaveAs2 FileName:=FileName, FileFormat:=wdFormatXMLDocument
NewDoc.Close SaveChanges:=wdDoNotSaveChanges

Next PageNum

Application.ScreenUpdating = True

MsgBox "Готово! Створено " & TotalPages & " файлів у папці:" & vbCrLf & SavePath, vbInformation

End Sub