Am Code liegt es sicher nicht – eher an (d)einer Schleife!

Hab das mal kurz aufgebohrt, aber nichts Wesentliches verändert.

OK – process-explorer zeigt, dass Excel & Co. ganz schön rappeln,

aber immer noch im zugeteilten working-set

(gesamt 6 Dateien mit 50 - 200 Seiten und 250 - 550 Ersetzungen
und Laufzeit 4 - 24 sec)

Run-time error '-2147417851 (80010105)'

 klingt für mich wie ein Dateisystemfehler Made by Windows

In die Test() mal eine Fehlerbehandlung eingebaut, ob der Fehler abzufangen

Option Explicit

Sub Schleife()
'
' Vorgaben:
' aktive Excel-Tabelle
' [A1] - Pfad zum Word Dokument (hier: E:\Temp\Test.docx)
' [A2] - [Ax] Suchbegriffe

' [B1] - Pfad zum Word Dokument (hier: C:\Temp\Tast.docx)
' [B2] - [Bx] Suchbegriffe

' usw.

' gesamt 6 Dateien mit 50 - 200 Seiten und 250 - 550 Ersetzungen

Dim oWsh As Excel.Worksheet
Dim rngc As Excel.Range       'alles
Dim rngF As Excel.Range       'Dateinamen
Dim rngT As Excel.Range       'Ersetzungsliste
Dim x As Long

Set oWsh = ThisWorkbook.ActiveSheet

For x = 1 To oWsh.UsedRange.Columns.Count
   Set rngc = Range(Cells(1, x), Cells(1, x).End(xlDown))
   Set rngF = rngc.Cells(1)    'Datei
   Set rngT = rngc.Offset(1, 0).Resize(rngc.Rows.Count - 1, _
      rngc.Columns.Count)
   'Debug.Print rngc.Address, rngF.Address, rngT.Address
   MeinTest rngF, rngT
Next x

End Sub


Private Sub MeinTest(rngFile As Range, rngSubst As Range)
'******************************************************************************
'
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 oExcelList = CreateObject("System.Collections.ArrayList")
  
   oExcelList.Add rngFile.Text
   
   For Each c In rngSubst
      oExcelList.Add c.Text
   
   Next c
  
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!")
  
Set oWordApp = Nothing
Set oWordDoc = Nothing
Set wdr = Nothing
Set oExcelSheet = Nothing
Set oExcelList = Nothing
  
End Sub


'*******************************************************************************
'hier einmal eine Fehlersteuerung eingebaut
'ob überhaupt abzufangen
Sub Test()
'
'******************************************************************************
' Name : Test / erstellt : 03.12.2014 / 15:10 / Sub
'------------------------------------------------------------------------------
'
'
'
Const m_ModName As String = "mdl_FindInWordDoc"
Const m_PrcName As String = "Test"
Dim m_SendKey As String: m_SendKey = Chr(123) & "F8" & Chr(125)
'
'******************************************************************************
'
'
' 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
  
'
   On Error GoTo Test_Error
   'lCnt = lCnt / 0 Test
'
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!")
'
   On Error GoTo 0
'
Test_Error:
'------------------------------------------------------------------------------
Select Case Err.Number
  Case Is = 0: 'errorless
  ' Case is = #: 'custom
  Case Else: 'display
      Select Case MsgBox(Format(Err.Number, "   #0") & "/" & Err.Description & _
         Chr(13) & Chr(13) & "   Debugmodus starten ?", _
         vbYesNo Or vbCritical Or vbDefaultButton1, _
         m_ModName & " / " & m_PrcName)
      Case vbYes
         Application.SendKeys Keys:=m_SendKey & m_SendKey, Wait:=False
         Stop: Resume
      Case vbNo
         ' Abbruch
   End Select
End Select
'------------------------------------------------------------------------------
  
End Sub