Option Explicit
Sub Test()
Dim oExcelList As Object
Dim oExcelSheet As Excel.Worksheet
Dim c As Excel.Range
Dim oWordApp As Word.Application
Dim oWordDoc As Word.Document
Dim wdr As Word.Range
Dim sText As String
Dim lCnt As Long, lFnd As Long
Set oExcelSheet = ThisWorkbook.ActiveSheet
Set c = oExcelSheet.Range("A1")
Set oExcelList = CreateObject("System.Collections.ArrayList")
oExcelList.Add c.Text
Set c = c.Offset(1)
Do While c.Text <> vbNullString
oExcelList.Add c.Text
Set c = c.Offset(1)
Loop
Set oWordApp = CreateObject("Word.Application")
Set oWordDoc = oWordApp.Documents.Open(oExcelList.Item(0))
With oWordDoc
Set wdr = .Content
For lCnt = 1 To oExcelList.Count - 1
sText = oExcelList.Item(lCnt)
lFnd = 0
Do
wdr.Find.Execute FindText:=sText, Forward:=True
If Not wdr.Find.Found Then Exit Do
With wdr
.Bold = True
.Font.ColorIndex = wdRed
End With
lFnd = lFnd + 1
oExcelList.Item(lCnt) = sText & Format(lFnd, " #0 Ersetzungen")
Loop
Set wdr = .Content
Next lCnt
End With
oWordDoc.Close
oWordApp.Quit
Call MsgBox(Join(oExcelList.toarray(), Chr(10)), vbInformation, "Geschafft!")
End Sub