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