Sub BreakOnPage()
   ' Used to set criteria for moving through the document by page.
   Application.Browser.Target = wdBrowsePage

   For i = 1 To ActiveDocument.BuiltInDocumentProperties("Number of Pages")
      
      'Select and copy the text to the clipboard
      ActiveDocument.Bookmarks(".pa").Range.Copy

      ' Open new document to paste the content of the clipboard into.
      Documents.Add
      Selection.Paste

      ' Removes the break that is copied at the end of the page, if any.
      Selection.TypeBackspace
      ChangeFileOpenDirectory "D:\"
      DocNum = DocNum + 1
      ActiveDocument.SaveAs FileName:="test_" & DocNum & ".doc"
      ActiveDocument.Close

      ' Move the selection to the next page  in the document
      Application.Browser.Next
   Next i
   ActiveDocument.Close savechanges:=wdDoNotSaveChanges
End Sub

Sub SplitDocument()
Application.ScreenUpdating = False
Dim DocSrc As Document, DocTgt As Document, i As Long
Dim Rng As Range, HdFt As HeaderFooter, j As Long
Set DocSrc = ActiveDocument
With DocSrc
  ' Create, copy & delete a temporary Section break.
  With .Range
    Set Rng = .Characters.First
    With Rng
      .Collapse wdCollapseStart
      .InsertBreak Type:=wdSectionBreakNextPage
      .Start = .Start - 1
      .Copy
      .Delete
    End With
    ' Replace all instances of .pa with the copied Section break
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = ".pa"
      .Replacement.Text = "^c"
      .Forward = True
      .Format = False
      .Wrap = wdFindContinue
      .Execute Replace:=wdReplaceAll
      If .Found = False Then Exit Sub
    End With
  End With
  ' Process each Section
  For i = 1 To .Sections.Count
    ' Get the whole Section
    Set Rng = .Sections(i).Range
    ' Contract the range to exclude the Section break
    With Rng
      .MoveEnd wdCharacter, -1
      Do While .Characters.Last.Previous.Text = vbCr
        .Characters.Last.Previous.Text = vbNullString
      Loop
      If Len(.Text) > 1 Then
        j = j + 1
        ' Copy the range
        .Copy
        ' Create the output document
        Set DocTgt = Documents.Add(Template:=DocSrc.AttachedTemplate.FullName, Visible:=False)
        With DocTgt
          ' Paste contents into the output document, preserving the formatting
          .Range.PasteAndFormat (wdFormatOriginalFormatting)
          ' Delete trailing paragraph breaks & page breaks at the end
          While .Characters.Last.Previous = vbCr
            .Characters.Last.Previous = vbNullString
          Wend
          ' Replicate the headers & footers
          For Each HdFt In DocSrc.Sections(i).Headers
            .Sections(1).Headers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
          Next
          For Each HdFt In DocSrc.Sections(i).Footers
            .Sections(1).Footers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
          Next
          ' Save & close the output document
          .SaveAs FileName:=Split(DocSrc.FullName, ".doc")(0) & "_" & j & ".docx", _
            FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
          .Close SaveChanges:=False
        End With
      End If
    End With
  Next
End With
Set Rng = Nothing: Set DocTgt = Nothing: Set DocSrc = Nothing
Application.ScreenUpdating = True
End Sub

Sub SplitDoc()
Const strName As String = "Test_" 'the name of the files
Const strPath As String = "C:\Path\" 'the folder to save the files
Dim strDocName As String
Dim oDoc As Document
Dim oRng As Range, oSplit As Range
Dim oNewDoc As Document
Dim strDelim As String: strDelim = ".pa"
Dim Counter As Integer: Counter = 1
Dim strOriginalName As String

    Set oDoc = ActiveDocument
    oDoc.Save
    If oDoc.path = "" Then Beep: GoTo lbl_Exit
    strOriginalName = oDoc.FullName
    Set oRng = oDoc.Range


    Application.ScreenUpdating = False

    With oRng.Find
        Do While .Execute(FindText:=strDelim, MatchWholeWord:=True, MatchCase:=True)
            oRng.Text = ""
            Set oSplit = oRng
            oSplit.Start = ActiveDocument.Range.Start
            Set oNewDoc = Documents.Add(strOriginalName)
            oNewDoc.Range.FormattedText = oSplit.FormattedText
            strDocName = strPath & strName & _
                         LTrim$(Str$(Counter)) & ".docx"
            oNewDoc.SaveAs2 strDocName
            oNewDoc.Close
            Counter = Counter + 1
            oSplit.Text = ""
            oRng.Collapse 0
        Loop
    End With
    oDoc.SaveAs2 strDocName
    oDoc.Close wdDoNotSaveChanges
    Documents.Open strOriginalName
lbl_Exit:
    Set oDoc = Nothing
    Set oNewDoc = Nothing
    Set oRng = Nothing
    Set oSplit = Nothing
    Exit Sub
End Sub

Sub SplitDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String
Dim DocSrc As Document, DocTgt As Document, i As Long
Dim Rng As Range, HdFt As HeaderFooter, j As Long
strDocNm = ActiveDocument.FullName
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.txt", vbNormal)
While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    Set DocSrc = Documents.Open(FileName:=strFolder & "\" & strFile, _
      ConfirmConversions:=False, AddToRecentFiles:=False, Visible:=False)
    With DocSrc
      ' Create, copy & delete a temporary Section break.
      With .Range
        Set Rng = .Characters.First
        With Rng
          .Collapse wdCollapseStart
          .InsertBreak Type:=wdSectionBreakNextPage
          .Start = .Start - 1
          .Copy
          .Delete
        End With
        ' Replace all instances of .pa with the copied Section break
        With .Find
          .ClearFormatting
          .Replacement.ClearFormatting
          .Text = ".pa"
          .Replacement.Text = "^c"
          .Forward = True
          .Format = False
          .Wrap = wdFindContinue
          .Execute Replace:=wdReplaceAll
        End With
      End With
      ' Process each Section
      j = 0
      For i = 1 To .Sections.Count
        ' Get the whole Section
        Set Rng = .Sections(i).Range
        ' Contract the range to exclude the Section break
        With Rng
          .MoveEnd wdCharacter, -1
          Do While .Characters.Last.Previous.Text = vbCr
            .Characters.Last.Previous.Text = vbNullString
          Loop
          If Len(.Text) > 1 Then
            j = j + 1
            ' Copy the range
            .Copy
            ' Create the output document
            Set DocTgt = Documents.Add(Template:=DocSrc.AttachedTemplate.FullName, Visible:=False)
            With DocTgt
              ' Paste contents into the output document, preserving the formatting
              .Range.PasteAndFormat (wdFormatOriginalFormatting)
              ' Delete trailing paragraph breaks & page breaks at the end
              While .Characters.Last.Previous = vbCr
                .Characters.Last.Previous = vbNullString
              Wend
              ' Replicate the headers & footers
              For Each HdFt In DocSrc.Sections(i).Headers
                .Sections(1).Headers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
              Next
              For Each HdFt In DocSrc.Sections(i).Footers
                .Sections(1).Footers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
              Next
              ' Save & close the output document
              .SaveAs FileName:=Split(DocSrc.FullName, ".txt")(0) & "_" & j & ".docx", _
                FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
              .Close SaveChanges:=False
            End With
          End If
        End With
      Next
      .Close SaveChanges:=False
    End With
  End If
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

'oDoc.SaveAs2 strDocName
    oDoc.Close wdDoNotSaveChanges

End With
    strDocName = strPath & strName & _
                 LTrim$(Str$(Counter)) & ".docx"
    oDoc.SaveAs2 strDocName
    oDoc.Close wdDoNotSaveChanges
    Documents.Open strOriginalName