A Table of Content (TOC) under each heading 2 showing only the subheadings thereof

I have used 90 times heading 2 in my Word document of + 1000 pages. Every heading two has numerous subheadings. The end goal is to add a separate Table Of Content (TOC) under each heading 2 which shows only the subheadings under that specific heading 2 (the text of heading 2 itself excluded, which by itself can be done by limiting the TOC to headings 3 and smaller). Searching the net made it clear that this is not as simple as it sounds. There is for instance not a checkbox in the TOC options to limit the TOC to the next section break, so using section breaks is pointless to achieve this. The only method seems to be to add separate bookmarks to all the text under each heading 2 and to limit the TOC code to the bookmark in question where the TOC is situated.

I can't figure out a way to automatically create uniquely named bookmarks (for instance numbers 1 to 90 in my case) for each of the text selections under each heading 2. So I'm willing to do this manually. But it would already be a help not to select manually all the text under each heading 2.

So here is the question: which VBA code can help me with this selection? Or can you think of a code that goes much further in achieving the end goal?

The farthest I got was to find a heading 2 add two unusual symbols "£$" in front of it, go to the next heading 2 do the same and so on. The idea here is, once that is done, I just need to search with wild cards on $*£ to select the text from the one heading 2 to the next.

But my code keeps on looping (when the end of the document is reached it starts over from the top), and since today it doesn't seem to be working at all anymore. And, admittedly, maybe the whole method is a bit crappy. I nevertheless paste the code on the bottom.

A helping hand would be much appreciated, either by improving my code, by sharing other code that selects text under the next heading 2 in the document (a macro which I then can repeat manually to continue creating manual bookmarks in the document) or by finding a much better method to achieve the end goals of separate TOCs under each heading 2 with only the headings shown under that specific heading.

Thanks a lot in advance.

Willem

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

Solution

For example:

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