Sub SplitDocByHeading() 'Goes through the document and splits the document into new sections and names the word document files by heading type
Application.ScreenUpdating = False
Dim StrTmplt As String, StrPath As String, StrFlNm As String, Rng As Range, Doc As Document
With ActiveDocument
  StrTmplt = .AttachedTemplate.FullName
  StrPath = .Path & "\"
  With .Range
    With .Find   ' change these to search for specific formatting items
      .Text = ""
      .Style = "Heading 2"
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = True
      .MatchCase = False
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
    End With
    Do While .Find.Found
      Set Rng = .Paragraphs(1).Range.Duplicate
      With Rng
        StrFlNm = Replace(.Text, vbCr, "")
          If .Paragraphs.Last.Range.End = ActiveDocument.Range.End Then Exit Do
        Select Case .Paragraphs.Last.Next.Style
          Case "Heading 2" ' Update to set heading level
            Exit Do
          Case Else
            .MoveEnd wdParagraph, 1
          End Select
      End With
      Set Doc = Documents.Add(Template:=StrTmplt, Visible:=False)
      With Doc
        .Range.FormattedText = Rng.FormattedText
        .SaveAs2 FileName:=StrPath & StrFlNm, Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False 'can change wdFormatXMLDocument to one of the types below
        .Close False
      End With
      .Collapse wdCollapseEnd
  End With
End With
Set Doc = Nothing: Set Rng = Nothing
Application.ScreenUpdating = True
End Sub