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, 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
Select Case .ActiveSheet.Name
Case Is = "Füllw.": enmColor = wdColorRed
Case Is = "Adj.": enmColor = wdColorBrightGreen
Case Is = "SDT": enmColor = wdColorYellow
Case Is = "Adv.": enmColor = wdColorBlue
Case Is = "Seicht": enmColor = wdColorDarkRed
Case Is = "Werten": enmColor = wdColorLightBlue
Case Is = "Hellseh.": enmColor = wdColorViolet
Case Else: enmColor = wdColorTurquoise
End Select
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)
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
Private Sub prcSetBorders(ByRef probjBorder As Border, _
ByVal pvenmColor As WdColor)
With probjBorder
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = pvenmColor
End With
End Sub