vba - Copy headings and Contents to new document - Stack Overflow 

Sub SplitDocumentByHeading() 

Application.ScreenUpdating = False 

Dim DocSrc As Document, DocTgt As Document, Rng As Range, i As Long 

Dim StrTmplt As String, StrNm As String, StrEx As String, lFmt As Long 

Set DocSrc = ActiveDocument 

With DocSrc 

  StrTmplt = .AttachedTemplate.FullName 

  StrNm = Split(.FullName, ".doc")(0) 

  StrEx = Split(.FullName, ".doc")(1) 

  lFmt = .SaveFormat 

  With .Range 

    With .Find 



      .Text = "" 

      .Style = wdStyleHeading1 

      .Replacement.Text = "" 

      .Forward = True 

      .Wrap = wdFindStop 

      .Format = True 

      .MatchCase = False 

      .MatchWholeWord = False 

      .MatchWildcards = False 

      .MatchSoundsLike = False 

      .MatchAllWordForms = False 


    End With 

    Do While .Find.Found 

      i = i + 1 

      Set Rng = .Duplicate.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel") 

      Set DocTgt = Documents.Add(Template:=StrTmplt, Visible:=False) 

      With DocTgt 

        .Range.FormattedText = Rng.FormattedText 

        .SaveAs2 FileName:=StrNm & "_" & Format(i, "00") & ".txt", Fileformat:=wdFormatText, AddToRecentFiles:=False 'this sets the format 


      End With 

      .Collapse wdCollapseEnd 



  End With 

End With 

Set DocTgt = Nothing: Set Rng = Nothing: Set DocSrc = Nothing 

Application.ScreenUpdating = True 

End Sub 

downloadDownload PNG downloadDownload JPEG downloadDownload SVG

Tip: You can change the style, width & colours of the snippet with the inspect tool before clicking Download!

Click to optimize width for Twitter