Sub InsertRefs()
Application.ScreenUpdating = False
Dim RngHd2 As Range, RngHd3 As Range, RngRef As Range, oPara As Paragraph
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Style = "Heading 2"
    .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 RngHd2 = .Paragraphs(1).Range.Duplicate
    With RngHd2
      On Error GoTo ParaLast
      While .Paragraphs.Last.Next.Style <> "Heading 1" And .Paragraphs.Last.Next.Style <> "Heading 2"
        .MoveEnd wdParagraph, 1
      Wend
ParaLast:
      If .Paragraphs.Count > 2 Then
        Set RngRef = RngHd2.Paragraphs(3).Range.Characters.Last
        .MoveStart wdParagraph, 3
        Set RngHd3 = RngHd2
        With RngRef
          .MoveEnd wdCharacter, -1
          .InsertAfter " { "
          For Each oPara In RngHd3.Paragraphs
            If oPara.Style = "Heading 3" Then
              If Len(Trim(oPara.Range.Text)) > 1 Then
                .InsertAfter Left(oPara.Range.Text, Len(oPara.Range.Text) - 1) & ", "
              End If
            End If
          Next
          .Characters.Last.Previous.Delete
          .InsertAfter "}."
        End With
      End If
    End With
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Application.ScreenUpdating = True
End Sub