Moin, 

folgendes Problem, ich habe eine Liste mit Wörtern, zu den ich mir gerne die Synonyme ausgeben lassen würde.

Die Wörter stehen in Spalte A1:A1543 und sollen dann um den Inhalt in den Spalten B,C&D ergänzt w

Ich habe es hiermit in Word probiert

Sub GetSynonyms()
    Dim msg As String
    Dim var
    Dim i As Long
    Dim mySi As SynonymInfo
    Dim synList() As String
    
    Selection.Expand Unit:=wdWord
    Set mySi = Selection.Range.SynonymInfo
    For var = 1 To 1
        synList = mySi.SynonymList(Meaning:=var)
        For i = 1 To 3
            iSynonyms = iSynonyms & synList(i) & ", "
        Next i
    Next
    Debug.Print iSynonyms
End Sub

Der Code stammt von folgender Seite https://www.mrexcel.com/forum/excel-questions/894170-find-synonyms-word-ms-excel-using-vba.htmlSub GetSynonyms()

In Zeile 8  "Set mySi = Selection.Range.SynonymInfo" bekomme ich nur einen Run-time error 5843 und habe keine Ahnung warum.

Dem Threadersteller des Links oben hat folgendes weitergeholfen

https://www.mrexcel.com/forum/general-excel-discussion-other-questions/559715-parts-speech-wordlist-excel-using-vba.html

Option Explicit
 
Public Sub PartsOfSpeech()
 
  Dim mObjWord As Word.Application
  Dim mySynInfo As Word.SynonymInfo
  Dim myList As Variant
  Dim myPos As Variant
  Dim i As Integer
  Dim iMax As Integer
  Dim thisPos As String
  Dim oCell As Range
 
  Set mObjWord = CreateObject("Word.Application")
  
  iMax = 1
 
  For Each oCell In Selection
    oCell.Offset(0, 1).Resize(1, 99).ClearContents
    If oCell.Column = 1 And Not IsEmpty(oCell) Then
      Set mySynInfo = SynonymInfo(Word:=oCell.Value, LanguageID:=wdEnglishUS)
      oCell.Offset(0, 1) = "'(" & CStr(mySynInfo.MeaningCount) & ")"
      If mySynInfo.MeaningCount <> 0 Then
        myList = mySynInfo.MeaningList
        myPos = mySynInfo.PartOfSpeechList
        If i > iMax Then iMax = i
        For i = 1 To UBound(myPos)
          Select Case myPos(i)
            Case wdAdjective
              thisPos = "adjective"
            Case wdNoun
              thisPos = "noun"
            Case wdAdverb
              thisPos = "adverb"
            Case wdVerb
              thisPos = "verb"
            Case wdConjunction
              thisPos = "conjunction"
            Case wdIdiom
              thisPos = "idiom"
            Case wdInterjection
              thisPos = "interjection"
            Case wdPreposition
              thisPos = "preposition"
            Case wdPronoun
              thisPos = "pronoun"
             Case Else
              thisPos = "other"
          End Select
          oCell.Offset(0, i + 1) = myList(i) & " (" & thisPos & ")"
        Next i
      Else
        oCell.Offset(0, 2) = "No meanings found"
      End If
    End If
  Next oCell
  
  For i = 3 To iMax
    Columns(i).EntireColumn.AutoFit
  Next i
 
End Sub

Dim wdApp As Word.Application

Public Sub SynonymFind()
vColumn = Left(Columns(ActiveCell.Column).Address(0, 0), 2 + (ActiveCell.Column < 27))

Set wdApp = New 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:=wdGerman).Found = True _
And wdApp.SynonymInfo(Word:=vSyn, LanguageID:=wdGerman).MeaningCount > 0 Then

vList = SynonymInfo(Word:=vSyn, LanguageID:=wdGerman).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