|
ersetze diesen Teil
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
durch
Farbe = Array(12324, 37373, usw ) 'die 12 RGB-Werte
lr = xlApp.cells(rows.count, "A").end(xlup).row
for j = 1 to 12
for i = 1 to lr
if not isempty(cells(i,j) then
With myRange
For Each AktWord In .Words
TmpStr = Trim(AktWord.Text)
If UCase(TmpStr) Like AllWord(iWord) & "*" Then
AktWord.Font.Color.rgb = Farbe(j-1)
End If
Next AktWord
End With
endif
next i
next j
In Word dürfte es besser sein, die "Find" bzw "Replace" - methode zu nutzen, so wird es ziemlich lange dauern.
Warnung: der code ist ohne Test zusammengestoppelt, führe ihn zuerst im Einzelschritt-Modus aus
|