Sub SynonymFind()
Dim wdApp As Object
vColumn = Left(Columns(ActiveCell.Column).Address(0, 0), 2 + (ActiveCell.Column < 27))
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
wdApp.Documents.Add DocumentType:=wdNewBlankDocument
Do While ActiveCell.Row <= Cells(Rows.Count, vColumn).End(xlUp).Row
On Error GoTo NextWord
vSyn = Application.Proper(ActiveCell.Text)
If wdApp.SynonymInfo(Word:=vSyn, LanguageID:=wdFrench).Found = True _
And wdApp.SynonymInfo(Word:=vSyn, LanguageID:=wdFrench).MeaningCount > 0 Then
vList = wdApp.SynonymInfo(Word:=vSyn, LanguageID:=wdFrench).SynonymList(1)
wdApp.Selection.TypeText Text:="The Synonyms for "
wdApp.Selection.Font.Bold = wdToggle
wdApp.Selection.TypeText Text:=vSyn & ": "
wdApp.Selection.Font.Bold = wdToggle
For i = 1 To UBound(vList)
If i = UBound(vList) Then
wdApp.Selection.TypeText Application.Proper(vList(i))
Else
wdApp.Selection.TypeText Application.Proper(vList(i)) & " "
End If
Next i
End If
wdApp.Selection.TypeParagraph
wdApp.Selection.TypeParagraph
NextWord:
ActiveCell.Offset(1, 0).Select
Loop
End Sub