You can add a little polish to the output by leveraging the fact that a dictionary key and be a range object:
Code:
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