Sub InsertRefs()
Application.ScreenUpdating = False
Dim RngHdA As Range, RngHdB As Range, RngRef As Range
Dim iRefHd As Long, StrTxt As String, oPara As Paragraph
On Error Resume Next
iRefHd = InputBox("What is the Reference Heading Level Number (from 1 to 8)?", "Heading Selector")
' Word's inbuilt heading styles are indexed as -2 to -10, so invert the input # and subtract 1
iRefHd = -iRefHd - 1
On Error GoTo 0
' Valid #s must be between -2 (Heading 1) and -9 (Heading 8)
If iRefHd > -2 Or iRefHd < -9 Then Exit Sub
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Style = iRefHd
    .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
    Set RngHdA = .Paragraphs(1).Range.Duplicate
    With RngHdA
      On Error GoTo ParaLast
      While ActiveDocument.Styles(.Paragraphs.Last.Next.Style).BuiltIn = False Or _
        .Paragraphs.Last.Next.Style > ActiveDocument.Styles(iRefHd) Or _
        .Paragraphs.Last.Next.Style < ActiveDocument.Styles(iRefHd + 1)
          .MoveEnd wdParagraph, 1
      Wend
ParaLast:
      StrTxt = ""
      If .Paragraphs.Count > 2 Then
        Set RngRef = RngHdA.Paragraphs(3).Range.Characters.Last
        .MoveStart wdParagraph, 3
        Set RngHdB = RngHdA
        With RngRef
          .MoveEnd wdCharacter, -2
          For Each oPara In RngHdB.Paragraphs
            If ActiveDocument.Styles(oPara.Style).BuiltIn = True Then
              ' To get all lower Heading Styles, change '(iRefHd - 2)' to '(-11)'
              If oPara.Style < ActiveDocument.Styles(iRefHd - 2) And _
                oPara.Style > ActiveDocument.Styles(iRefHd) Then
                If Len(Trim(oPara.Range.Text)) > 1 Then
                  StrTxt = StrTxt & Left(oPara.Range.Text, Len(oPara.Range.Text) - 1) & ", "
                End If
              End If
            End If
          Next
          If Len(StrTxt) > 0 Then
            StrTxt = "{" & Left(StrTxt, Len(StrTxt) - 2) & "}"
            .InsertAfter StrTxt
          End If
        End With
      End If
    End With
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Application.ScreenUpdating = True
End Sub