Sub ListSynonyms()
Dim oSynInfo As Object
Dim varList As Variant
Dim lngindex As Long, lngSyn As Long
Dim strSyns As String
Dim oDoc As Document, oDocReport As Document
Dim oRng As Range
Dim arrList() As String
Dim oDic As Object
Dim oKey
  Set oDic = CreateObject("Scripting.Dictionary")
  Application.ScreenUpdating = False
  Set oDoc = ActiveDocument
  Set oDocReport = Documents.Add
  Set oRng = oDoc.Range
  arrList = Split("layout|Content|many|Various|sometimes|use", "|")
  Set oRng = oDoc.Range
  With oRng.Find
    .Font.Bold = True
    While .Execute
      If Not oDic.Exists(oRng.Text) Then
        Set oSynInfo = oRng.SynonymInfo
        varList = oSynInfo.SynonymList(1)
        Select Case UBound(oSynInfo.SynonymList(1))
          Case 0
            strSyns = varList(0) & "."
          Case 1
            strSyns = varList(0) & " and " & varList(1) & "."
          Case Else
            For lngSyn = 1 To UBound(oSynInfo.SynonymList(1))
              Select Case lngSyn
                Case Is = 1: strSyns = varList(lngSyn)
                Case UBound(oSynInfo.SynonymList(1)): strSyns = strSyns & " and " & varList(lngSyn) & "."
                Case Else: strSyns = strSyns & ", " & varList(lngSyn)
              End Select
            Next
        End Select
        oDic.Add oRng.FormattedText, strSyns
        oRng.Collapse wdCollapseEnd
      End If
    Wend
  End With
  With oDocReport
    For Each oKey In oDic
      Set oRng = .Range
      With oRng
        .Collapse wdCollapseEnd
        .FormattedText = oKey
        .Collapse wdCollapseEnd
        .InsertAfter " - " & oDic.Item(oKey) & vbCr
        .Font.Bold = False
        .Paragraphs.Last.SpaceAfter = 12
      End With
    Next oKey
    .Paragraphs.Last.Range.Delete
    .Activate
  End With
  Application.ScreenUpdating = True
  Set oRng = Nothing: Set oDic = Nothing
lbl_Exit:
  Exit Sub
End Sub