Sub Markieren()
Dim wrd As Range, x As String, y As String, i As Long, cnt As Long
cnt = ActiveDocument.Words.Count
For Each wrd In ActiveDocument.Words
i = i + 1
If wrd.Bold = True Then wrd.HighlightColorIndex = wdBrightGreen
If wrd Like "Document*" Then wrd.HighlightColorIndex = wdPink
If i < cnt - 2 Then x = wrd & wrd.Next(wdWord) & wrd.Next(wdWord).Next(wdWord)
If i < cnt - 3 Then y = x & wrd.Next(wdWord).Next(wdWord).Next(wdWord)
If IsDate(y) Then
If wrd.Next(wdWord).Next(wdWord).Next(wdWord).End = wrd.Next(wdWord).Next(wdWord).Next(wdWord).Paragraphs(1).Range.End Then
ActiveDocument.Range(wrd.Start, wrd.Next(wdWord).Next(wdWord).Next(wdWord).End).HighlightColorIndex = wdYellow
End If
ElseIf IsDate(x) Then
If wrd.Next(wdWord).Next(wdWord).End = wrd.Next(wdWord).Next(wdWord).Paragraphs(1).Range.End Then
ActiveDocument.Range(wrd.Start, wrd.Next(wdWord).Next(wdWord).End).HighlightColorIndex = wdYellow
End If
End If
Next wrd
MsgBox "Fertig!"
End Sub