Using Thesaurus with VBA

[th081]

Hi,

I have a list of words in column A, when i select a cell with a word and press thesaurus under the review tab Excel shows a few alternative definitions of the word. There is one main heading then a few words below that heading. Is it possible using VBA or other to pull those alternative definitions into the sheet next to the word so the main heading then four of the words below the main heading? In columns B onward?

 

[footoo]

Adapted from here : Using The Thesaurus in VBA
The code can probably be shortened :

Public Sub Syno()
Dim MSWord As Object, oSynInfo As Object
Dim vSynList As Variant
Dim strWord As String, cel As Range, i1%, i2%
Set MSWord = CreateObject("Word.Application")
For Each cel In Range("A1:A" & Cells(Rows.Count, "A").End(3).Row)
strWord = cel
cel(1, 2).Resize(, Columns.Count - 1).ClearContents
Set oSynInfo = MSWord.SynonymInfo(strWord)
If oSynInfo.Found = True Then
    For i1 = 1 To oSynInfo.MeaningCount
        vSynList = oSynInfo.SynonymList(i1)
        For i2 = 1 To UBound(vSynList)
            Cells(cel.Row, Columns.Count).End(1)(1, 2) = vSynList(i2)
        Next i2
    Next i1
End If
Next
[G7].Resize(, Columns.Count - 6).EntireColumn.ClearContents
Set oSynInfo = Nothing
Set MSWord = Nothing
End Sub

 

[footoo]

Shortened a bit :

Public Sub Syno()
Dim MSWord As Object, oSynInfo As Object
Dim vSynList As Variant
Dim strWord As String, cel As Range, i1%, i2%
Set MSWord = CreateObject("Word.Application")
For Each cel In Range("A1:A" & Cells(Rows.Count, "A").End(3).Row)
    strWord = cel
    cel(1, 2).Resize(, Columns.Count - 1).ClearContents
    Set oSynInfo = MSWord.SynonymInfo(strWord)
    If oSynInfo.Found = True Then
        For i1 = 1 To 1
            vSynList = oSynInfo.SynonymList(i1)
            For i2 = 1 To 5
                Cells(cel.Row, Columns.Count).End(1)(1, 2) = vSynList(i2)
            Next i2
        Next i1
    End If
Next
Set oSynInfo = Nothing
Set MSWord = Nothing
End Sub

 

[th081]

Hello Footoo,

Thank you. This almost works, but it only brings back the first main item. For example Navigate has two main words in bold in the thesaurus: Circumnavigate and Steer (both are verbs). I'd like to pull these two main words plus the next four after each of them. At the moment its just pulling the first main heading whereas i'd like all the main headings.

Regards

 

[footoo]

Public Sub Syno()
Dim MSWord As Object, oSynInfo As Object
Dim vSynList As Variant
Dim strWord As String, cel As Range, i1, i2%
Set MSWord = CreateObject("Word.Application")
For Each cel In Range("A1:A" & Cells(Rows.Count, "A").End(3).Row)
    strWord = cel
    cel(1, 2).Resize(, Columns.Count - 1).ClearContents
    Set oSynInfo = MSWord.SynonymInfo(strWord)
    If oSynInfo.Found = True Then
        For i1 = 1 To oSynInfo.MeaningCount
            vSynList = oSynInfo.SynonymList(i1)
            For i2 = 1 To 5
                With Cells(cel.Row, Columns.Count).End(1)(1, 2)
                    .Value = vSynList(i2)
                    If i2 = 1 Then .Font.Bold = True
                End With
            Next i2
        Next i1
    End If
Next
Set oSynInfo = Nothing
Set MSWord = Nothing
End Sub

 

[footoo]

Amendment.

Replace this :

cel(1, 2).Resize(, Columns.Count - 1).ClearContents

With this :

With cel(1, 2).Resize(, Columns.Count - 1)
     .ClearContents
     .Font.Bold = False
End With

 

[th081]

Hello Footoo,

Thank you. It is sometimes throwing an error at:

.Value = vSynList(i2)

The error happens when the subwords under the main word have less than 5 words i.e wave has the main word 'curl' this has only 4 subwords under it so throws an error.

Regards

 

[footoo]

Here's a tidied-up version that should fix it :

Sub Syno()
Dim MSWord As Object, oSyn As Object
Dim cel As Range, i%, j%
Set MSWord = CreateObject("Word.Application")
Application.ScreenUpdating = False
With [B:B].Resize(, Columns.Count - 1)
    .ClearContents
    .Font.Bold = False
End With
On Error Resume Next
For Each cel In Range("A1:A" & Cells(Rows.Count, "A").End(3).Row)
    Set oSyn = MSWord.SynonymInfo(cel.Value)
    If oSyn.Found Then
        For i = 1 To oSyn.MeaningCount
            For j = 1 To 5
                With Cells(cel.Row, Columns.Count).End(1)(1, 2)
                    .Value = oSyn.SynonymList(i)(j)
                    If j = 1 Then .Font.Bold = True
                End With
            Next j
        Next i
    End If
Next
On Error GoTo 0
Set oSyn = Nothing
Set MSWord = Nothing
End Sub

 

[th081]

Thank you for your help Footoo,

that is fantastic