Option Explicit
Public Sub Adjektive()
Const xlUp As Long = -4162
Dim AktWord As Range
Dim AllWord() As String, iWord As Long, Found As Boolean
Dim TmpStr As String
Dim xlApp As Object
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
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
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
End With
End Sub