Sub SplitDoc_()
    
'Disable screen updating to improve performance
    Application.ScreenUpdating = False

'Declare variables
Dim Rng As range             ' Represents a range within the document
Dim Rng1                     ' Represents Heading1
Dim DocSrc As Document       ' Represents the source (original) document
Dim DocTgt As Document       ' Represents the target (newly created) document
Dim i As Long                ' Counter variable for loops
Dim StrTxt As String         ' Stores the title of the section
Const StrNoChr As String = """*./\:?|" ' List of illegal characters in filenames

'Set the source document as the currently active document
    Set DocSrc = ActiveDocument

'Configure find settings for heading style 1
    With DocSrc.range
        With .Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Format = True
            .Forward = True
            .text = ""
            .Style = wdStyleHeading1 ' Search for heading style 1
            .Replacement.text = ""
            .Wrap = wdFindStop
            .Execute
        End With
'Set the range for & remember Heading1:
        If .Find.found Then Set Rng1 = .Paragraphs(1).range
        Rng1.End = Rng1.End - 1

'Loop through the document and split based on heading style 1
        Do While .Find.found
'Set the range for the current heading
            Set Rng = .Paragraphs(1).range

'Move to the corresponding bookmark in the heading
            Set Rng = Rng.GoTo(What:=wdGoToBookmark, name:="\HeadingLevel")

'Create a new target document based on the source document's template
            Set DocTgt = Documents.Add(DocSrc.AttachedTemplate.FullName)

'Configure target document
            With DocTgt
'Copy the formatted text from the source heading to the target document
                .range.FormattedText = Rng.FormattedText

'Extract the text of the first paragraph (title) from the target document
                StrTxt = Split(.Paragraphs.First.range.text, vbCr)(0)

'Strip out illegal characters from the title
                For i = 1 To Len(StrNoChr)
                    StrTxt = Replace(StrTxt, Mid(StrNoChr, i, 1), "_")
                Next
'Save the target document with a modified filename and specific format
                .SaveAs2 fileName:=DocSrc.path & "\" & Rng1 & " - " & StrTxt & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False

'Close the target document without saving changes
                .Close False
            End With

'Move the starting point of the find operation to the end of the current heading
            .Start = Rng.End

'Perform the find operation again
            .Find.Execute
        Loop
    End With

'Clean up and restore screen updating
    Set Rng = Nothing
    Set DocSrc = Nothing
    Set DocTgt = Nothing
    Application.ScreenUpdating = True
End Sub