Copy headings and Contents to new document

Question

I am trying to create an audiobook with multiple tracks so it's easy to navigate through the book while I'm doing other things like driving or working out. The only way I can think to do this is to have each heading and its contents in its own separate document. I've been using the select headings and content option but there's no shortcut for this option. you must click it each time. everything I've looked at online doesn't do what I want. is there a way to select each heading and contents copy that to a new document, save it as TXT so each of the heading and content is in its own document?

Select Heading and Content

score 0 · Answer 1 · answered Feb 22 '20 at 03:37

You could use a macro like the following to split the document at the Heading1 level:

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
        .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

Rather more complex code would be required to split it at the sub-heading level.

Copy headings and Contents to new document

1 Answers1