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