Sub InsertRefs()
Application.ScreenUpdating = False
Dim RngHdA As Range, RngHdB As Range, RngRef As Range, oPara As Paragraph
Dim oSty As Style, StrStyList As String, strStyA, strStyB, StrTxt As String
Dim Msg As String, MsgA As String, MsgB As String, MsgErr As String
With ActiveDocument
  StrStyList = "|"
  MsgA = "What is the 'Main' Style to Find"
  MsgB = "What is the 'Sub' Style to Find"
  MsgErr = "No Such Style in this document" & vbCr
  For Each oSty In .Styles
    StrStyList = StrStyList & oSty.NameLocal & "|"
  Next
  Msg = MsgA
  While strStyA = ""
    strStyA = InputBox(Msg, "Style Selector")
    If strStyA = "" Then Exit Sub
    If InStr(StrStyList, "|" & strStyA & "|") = 0 Then
      strStyA = ""
      Msg = MsgErr & MsgA
    End If
  Wend
  Msg = MsgB
  While strStyB = ""
    strStyB = InputBox(Msg, "Style Selector")
    If strStyB = "" Then Exit Sub
    If InStr(StrStyList, "|" & strStyB & "|") = 0 Then
      strStyB = ""
      Msg = MsgErr & MsgB
    End If
  Wend
End With
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Style = strStyA
    .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 .Paragraphs.Last.Next.Style <> strStyA
        .MoveEnd wdParagraph, 1
      Wend
ParaLast:
      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 oPara.Style = strStyB Then
              If Len(Trim(oPara.Range.Text)) > 1 Then
                StrTxt = StrTxt & Left(oPara.Range.Text, Len(oPara.Range.Text) - 1) & ", "
              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

Heading 1
  some text
Heading 2
  some text
Heading 3
  some text
Heading 1
  some text
Heading 3
  some text