每个标题 2 下的目录 (TOC) 仅显示其子标题

Question

我在超过 1000 页的 Word 文档中使用了 90 次标题 2。每个标题二都有许多子标题。最终目标是在每个标题 2 下添加一个单独的目录 (TOC)，仅显示该特定标题 2 下的子标题（标题 2 本身的文本不包括在内，这本身可以通过将 TOC 限制为标题 3 来完成和更小）。搜索网络清楚地表明这并不像听起来那么简单。例如，TOC 选项中没有一个复选框来将 TOC 限制为下一个分节符，因此使用分节符来实现这一点毫无意义。唯一的方法似乎是为每个标题 2 下的所有文本添加单独的书签，并将 TOC 代码限制为 TOC 所在的相关书签。

我想不出一种方法来为每个标题 2 下的每个文本选择自动创建唯一命名的书签（例如数字 1 到 90）。所以我愿意手动执行此操作。但是不手动选择每个标题 2 下的所有文本已经是一种帮助。

那么问题来了：哪个 VBA 代码可以帮助我进行此选择？或者你能想出一个更进一步实现最终目标的代码吗？

我最远的是找到一个标题 2 在它前面添加两个不寻常的符号“£$”，转到下一个标题 2 做同样的事情，依此类推。这里的想法是，一旦完成，我只需要在 $*£ 上使用通配符进行搜索，以选择从一个标题 2 到下一个标题的文本。

但是我的代码一直在循环（当到达文档的末尾时，它从顶部重新开始），并且从今天开始它似乎不再工作了。而且，诚然，也许整个方法有点糟糕。尽管如此，我还是将代码粘贴在底部。

非常感谢您提供帮助，或者通过改进我的代码，通过共享其他代码来选择文档中下一个标题 2 下的文本（然后我可以手动重复该宏以继续在文档中创建手动书签）或者通过找到一种更好的方法来实现每个标题 2 下的单独 TOC 的最终目标，并且只显示该特定标题下的标题。

非常感谢。

威廉

Do While Selection.Find.Found = True
    
Selection.HomeKey Unit:=wdStory
        
Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles("Kop 2")
With Selection.Find
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindContinue
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
End With
    Selection.Find.Execute

If Selection.Find.Found Then
    Selection.MoveLeft Unit:=wdCharacter, Count:=1

    Selection.TypeText Text:="$£"
    Selection.MoveDown Unit:=wdLine, Count:=4
End If

Loop

Answer 1

例如：

Sub AddHeading2TOCs()
Application.ScreenUpdating = False
Dim RngHd As Range, h As Long
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Style = wdStyleHeading2
    .Format = True
    .Forward = True
    .Wrap = wdFindStop
  End With
  Do While .Find.Execute
    Set RngHd = .Paragraphs(1).Range: h = h + 1
    RngHd.InsertAfter vbCr
    Set RngHd = RngHd.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
    With RngHd
      .Paragraphs(2).Range.Style = wdStyleNormal
      .Start = .Paragraphs(2).Range.End
      .Bookmarks.Add "BkMkHd" & h, .Duplicate
      .Start = .Start - 1
      .Collapse wdCollapseStart
      .Fields.Add .Duplicate, wdFieldEmpty, "TOC \b BkMkHd" & h, False
    End With
    .Collapse wdCollapseEnd
  Loop
End With
Set RngHd = Nothing
Application.ScreenUpdating = True
End Sub