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

如何解决每个标题 2 下的目录 (TOC) 仅显示其副标题

我在超过 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

解决方法

例如：

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