将标题和内容复制到新文档答案

【问题标题】：Copy headings and Contents to new document将标题和内容复制到新文档
【发布时间】：2020-02-14 20:06:10
【问题描述】：

我正在尝试创建具有多个曲目的有声读物，以便在我做其他事情（例如开车或锻炼）时轻松浏览这本书。我能想到的唯一方法是将每个标题及其内容放在自己单独的文档中。我一直在使用选择标题和内容选项，但该选项没有快捷方式。您必须每次单击它。我在网上看到的所有内容都没有达到我想要的效果。有没有办法选择每个标题和内容将其复制到新文档中，将其另存为 TXT，以便每个标题和内容都在自己的文档中？

选择标题和内容

【问题讨论】：

标签： vba ms-word heading

【解决方案1】：

您可以使用如下宏在 Heading1 级别拆分文档：

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

需要更复杂的代码才能在子标题级别拆分它。

【讨论】：