Hallo Ambg,

der Code ist genau der, den ich oben bekommen habe. Die Pfadangabe stimmt auf jeden Fall. Ich hatte vorhin einmal einen falschen Pfad eingegeben, da wurde jedoch auch expliziert ausgeworfen, dass der Pfad nicht korrekt ist.

Theoretisch ist nichts offen. Das verwirrt mich ja so *hmmm*

Vielen Dank!

Option Explicit
 
Sub Test()
'
' Vorgaben:
' aktive Excel-Tabelle
' [A1] - Pfad zum Word Dokument (hier: E:\Temp\Test.docx)
' [A2] - [Ax] Suchbegriffe
'******************************************************************************
'
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