Sub SplitDocByHeading1()
Application.ScreenUpdating = False
Dim StrTmplt As String, StrPath As String, StrFlNm As String, Rng As Range, i As Long, Doc As Document
Const StrNoChr As String = """*./\:?|"
With ActiveDocument
  StrTmplt = .AttachedTemplate.FullName
  StrPath = .Path & "\"
  With .Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = ""
      .Replacement.Text = ""
      .Style = wdStyleHeading1
      .Format = True
      .Forward = True
      .Wrap = wdFindStop
      .Execute
    End With
    Do While .Find.Found
      Set Rng = .Duplicate
      StrFlNm = Split(Rng.Paragraphs(1).Range.Text, vbCr)(0)
      For i = 1 To Len(StrNoChr)
        StrFlNm = Replace(StrFlNm, Mid(StrNoChr, i, 1), "_")
      Next
      StrFlNm = StrFlNm & ".docx"
      Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
      Set Doc = Documents.Add(Template:=StrTmplt, Visible:=False)
      With Doc
        .Range.FormattedText = Rng.FormattedText
        .SaveAs2 FileName:=StrPath & StrFlNm, Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False
        .Close False
      End With
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
End With
Set Doc = Nothing: Set Rng = Nothing
Application.ScreenUpdating = True
End Sub