Sub SplitByHeading1()
Application.ScreenUpdating = False
Dim RngHd As Range, i As Long, Doc As Document, StrNm As String, StrExt As String, Fmt As Long
With ActiveDocument
  Fmt = .SaveFormat
  StrNm = Split(.FullName, ".do")(0)
  StrExt = ".do" & Split(.FullName, ".do")(1)
  With .Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = ""
      .Style = wdStyleHeading1
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = True
    End With
    Do While .Find.Execute
      Set RngHd = .Paragraphs(1).Range.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
      Set Doc = Documents.Add(ActiveDocument.AttachedTemplate.FullName): i = i + 1
      With Doc
        .Range.FormattedText = RngHd.FormattedText
        .SaveAs2 FileName:=StrNm & "(" & i & ")" & StrExt, Fileformat:=Fmt, AddToRecentFiles:=False
        .Close False
      End With
      .Start = RngHd.End
    Loop
  End With
End With
Set RngHd = Nothing: Set Doc = Nothing
Application.ScreenUpdating = True
End Sub