Danke, dass Du das Makro lesen möchtest.
Dabei muss das Excel-Blatt geöffnet sein.
Sub WörterAusExcel()
Dim myRange As Range, AktWord As Variant
Dim AllWord() As String, iWord As Long, Found As Boolean
Dim TmpStr As String
Set myRange = ActiveDocument.Range
Dim xlApp As Object ' Excel.Application
Dim SuchRange As Object, AktZelle As Object
Set xlApp = GetObject(, "Excel.Application")
Set SuchRange = xlApp.Range("A1:A5000")
With SuchRange
For Each AktZelle In SuchRange
If Len(AktZelle & "") > 0 Then
ReDim Preserve AllWord(iWord)
AllWord(iWord) = UCase(AktZelle)
iWord = iWord + 1
End If
Next
End With
Set myRange = ActiveDocument.Range
With myRange
For Each AktWord In .Words
TmpStr = Trim(AktWord.Text)
For iWord = 0 To UBound(AllWord)
If UCase(TmpStr) Like AllWord(iWord) & "*" Then
AktWord.Font.Color = wdColorYellow
End If
Next
Next
End With
Set SuchRange = Nothing
Set myRange = Nothing
End Sub
|