Hallo,

okidoki, die Leerzeichen sind hartnäckig, aber probiers mal hiermit...

Option Explicit

Public Sub Adjektive()
Const xlUp As Long = -4162 '// Konstante der Excel-App...
Dim AktWord As Range
Dim AllWord() As String, iWord As Long, Found As Boolean
Dim TmpStr As String

' Exceldaten aus offener Arbeitsmappe einlesen
' Aktuell 1. Spalte Zeile 1-5000
Dim xlApp As Object ' Excel.Application
Dim avntSearchWords() As Variant
Dim ialngIndex As Long
Set xlApp = GetObject(Class:="Excel.Application")
With xlApp
    avntSearchWords = .Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 1).Value '// <--- an Stelle von --  Range("A1:A5000") -- besser so....
End With
For ialngIndex = 1 To UBound(avntSearchWords, 1)
    If Len(avntSearchWords(ialngIndex, 1) & "") > 0 Then
      ReDim Preserve AllWord(iWord) As String
      AllWord(iWord) = UCase$(avntSearchWords(ialngIndex, 1))
      iWord = iWord + 1
    End If
Next
' Worddokument durchsuchen und Wörter Rot färben
With ActiveDocument.Range
    For Each AktWord In .Words
       With AktWord
            TmpStr = Trim$(.Text)
            For iWord = 0 To UBound(AllWord)
                 If UCase$(TmpStr) Like AllWord(iWord) & "*" Then
                     If Len(TmpStr) <> .Characters.Count Then
                        Call prcSetBorders(probjBorder:= _
                          ActiveDocument.Range(Start:=.Characters(1).Start, _
                            End:=.Characters(.Characters.Count).Start).Font.Borders(1))
                     Else
                        Call prcSetBorders(probjBorder:=.Font.Borders(1))
                     End If
                 End If
            Next
       End With
    Next
End With
Set xlApp = Nothing
End Sub

Private Sub prcSetBorders(ByRef probjBorder As Border)
With probjBorder
    .LineStyle = wdLineStyleSingle
    .LineWidth = wdLineWidth150pt
    .ColorIndex = wdRed '//wdBrightGreen
End With
End Sub

Gruß,