Word – Splitting by Heading to Txt Files (All Headings)

PHOTO EMBED

Tue Apr 12 2022 04:58:44 GMT+0000 (Coordinated Universal Time)

Saved by @cnewnham #vba

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 

      .ClearFormatting 

      .Replacement.ClearFormatting 

      .Text = "" 

      .Style = wdStyleHeading1 

      .Replacement.Text = "" 

      .Forward = True 

      .Wrap = wdFindStop 

      .Format = True 

      .MatchCase = False 

      .MatchWholeWord = False 

      .MatchWildcards = False 

      .MatchSoundsLike = False 

      .MatchAllWordForms = False 

      .Execute 

    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 

        .Close 

      End With 

      .Collapse wdCollapseEnd 

      .Find.Execute 

    Loop 

  End With 

End With 

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

Application.ScreenUpdating = True 

End Sub 

content_copyCOPY

https://stackoverflow.com/questions/60232841/copy-headings-and-contents-to-new-document