Hallo nochmal,

...freut mich zu hören, dabei fiel mir noch ein, das Select-Case-Gewürge brauchts nicht, Du kannst direkt auf Tab-Color-Eig. des TabBlattes zugreifen, der Rest bleibt so...

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, lngCount As Long
Dim enmColor As WdColor
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....
    '// ColorIndizes unterschied. nach akt. TabBatt...
    enmColor = .ActiveSheet.Tab.Color
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 färben
With ActiveDocument.Range
    For Each AktWord In .Words
       With AktWord
            TmpStr = Trim$(.Text)
            lngCount = .Characters.Count
            For iWord = 0 To UBound(AllWord)
                 If UCase$(TmpStr) Like AllWord(iWord) & "*" Then
                     If Len(TmpStr) = lngCount Then
                        Call prcSetBorders(probjBorder:=.Font.Borders(1), _
                         pvenmColor:=enmColor)
                     Else
                        Call prcSetBorders(probjBorder:= _
                          ActiveDocument.Range(Start:=.Characters(1).Start, _
                            End:=.Characters(lngCount).Start).Font.Borders(1), _
                             pvenmColor:=enmColor)
                     End If
                     Exit For
                 End If
            Next
       End With
    Next
End With
Set xlApp = Nothing
End Sub

Gruß,