Code:
Sub ExtractSynonyms()
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
Set oDic = CreateObject("Scripting.Dictionary")
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
oDic.Add oRng.Text, oRng.Text
strSyns = oRng.Text & " - "
Set oSynInfo = oRng.SynonymInfo
varList = oSynInfo.SynonymList(1)
For lngSyn = 1 To UBound(oSynInfo.SynonymList(1))
strSyns = strSyns & " " & varList(lngSyn)
Next
oRng.Collapse wdCollapseEnd
oDocReport.Range.InsertAfter strSyns & vbCr & vbCr
End If
Wend
End With
oDocReport.Activate
Set oRng = Nothing: Set oDic = Nothing
lbl_Exit:
Exit Sub
End Sub