Sub WörterAusExcel()
dim WB as object
set WB = GetObject(Pfad & File)
Farbe = Array(12345, 15686, 20000, 25000, 30000, 35000, 40000, 45000, 50000, 55000, 2500, 5000)
lr = WB.sheets(1).cells(rows.count, "A").end(xlup).row
for j = 1 to 12
for i = i to lr
With ActiveDocument.Range.Find
.Text = WB.sheets(1).cells(i,j)
.Replace.Font.Color = Farbe(j-1)
.Execute Replace:=wdReplaceAll
end with
next i
next j
End sub
_____________________________________