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

    ' Declare variables
    Dim Rng As Range             ' Represents a range within the document
    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

        ' 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 & "\" & 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