Option Explicit
Sub Schleife()
Dim oWsh As Excel.Worksheet
Dim rngc As Excel.Range
Dim rngF As Excel.Range
Dim rngT As Excel.Range
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)
Set rngT = rngc.Offset(1, 0).Resize(rngc.Rows.Count - 1, _
rngc.Columns.Count)
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
Sub Test()
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)
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
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:
Case Else:
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
End Select
End Select
End Sub