Vba 每个品目2下的目录（TOC），仅显示其子目

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

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

所以这里有一个问题：哪个VBA代码可以帮助我进行选择？或者你能想出一个代码，在实现最终目标方面走得更远吗

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

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

如果您能帮助我，我将不胜感激，无论是通过改进我的代码，还是通过共享选择文档中下一个标题2下文本的其他代码（我可以手动重复该宏以继续在文档中创建手动书签）或者找到一种更好的方法来实现每个标题2下单独的目标选择目标的最终目标，只在该特定标题下显示标题

先谢谢你

威廉

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

例如：

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

---

哇，大脚架。我不知道它是如何工作的，但它在每个标题2下都添加了一个完美的TOC。这是出乎意料的。您如何如此快速地创建此代码？我已经坐在这上面好几天了，才敢请求你的帮助。我真的很惊讶。非常感谢。«如何快速创建此代码»练习，熟悉VBA对象模型，并保留以前的代码库。既然您的问题已得到回答，请参阅Wow，Macropod。我不知道它是如何工作的，但它在每个标题2下都添加了一个完美的TOC。这是出乎意料的。您如何如此快速地创建此代码？我已经坐在这上面好几天了，才敢请求你的帮助。我真的很惊讶。非常感谢。«如何快速创建此代码»练习，熟悉VBA对象模型并保留以前的代码库。既然您的问题已得到回答，请参阅