Tabelle nach Wörtern durchsuchen und Kommentar ein

Option Explicit
Const wdreplaceAll = 2
Dim blnTMP As Boolean
Public Sub Main_1()
' Dimensionieren der Variablen
Dim wksSheet As Worksheet
Dim objDocument As Object
Dim varFiles As Variant
Dim intFiles As Integer
Dim lngLastRow As Long
Dim strDatei As String
Dim objApp As Object
Dim lngCalc As Long
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
On Error GoTo Fin
ChDrive ("C")
ChDir (ThisWorkbook.Path)
' Dateiauswahl - MEHRERE Dateien können ausgewählt werden
' Mit STRG / CTRL bzw. mit der Umschalttaste
varFiles = Application.GetOpenFilename( _
FileFilter:="Excel-Dateien (*.xlsx*), *.xlsx*", _
MultiSelect:=True)
If Not VarType(varFiles) = vbBoolean Then
' Die Excelapplikation wird ruhig gestellt
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
Set objApp = OffApp("Excel")
' Excel nicht sichtbar
Set objApp = OffApp("Excel", False)
If Not objApp Is Nothing Then
' Tabellenblattname gegebenenfalls anpassen
Set wksSheet = ThisWorkbook.Worksheets("Tabelle1")
' Mach das für alle im Dialog ausgewählten Dateien
For intFiles = 1 To UBound(varFiles)
' Exceldokument öffnen
Set objDocument = objApp.Document.Open _
(varFiles(intFiles))
' Schleife von Zeile 2 in Spalte B bis zum Ende von Spalte B
For lngLastRow = 2 To wksSheet.Cells _
(wksSheet.Rows.Count, 2).End(xlUp).Row
With objDocument.Content.Find
' Diesen Text suchen
.Text = wksSheet.Cells(lngLastRow, 2).Value
                        ' Mit diesem Text austauschen / ersetzen
.Replacement.Text = wksSheet.Cells(lngLastRow, 4).Value
' Tu es!
.Execute Replace:=wdreplaceAll

End With
Next lngLastRow
' Worddokument MIT speichern schliessen
objDocument.Close True
' Objektvariable leeren
Set objDocument = Nothing
' Die nächste ausgewählte Datei
Next intFiles
Else
MsgBox "Application not installed!"
End If
End If
Fin:
If Not objApp Is Nothing Then
If blnTMP = True Then
objApp.Quit
blnTMP = False
End If
End If
' Objektvariablen leeren
Set wksSheet = Nothing
Set objDocument = Nothing
Set objApp = Nothing
' Die Applikation aufwecken
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
.CutCopyMode = True
End With
' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
If Err.Number  0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String, _
Optional blnVisible As Boolean = True) As Object
Dim objApp As Object
On Error Resume Next
Set objApp = GetObject(, strApp & ".Application")
Select Case Err.Number
Case 429
Err.Clear
Set objApp = CreateObject(strApp & ".Application")
blnTMP = True
If blnVisible = True Then
On Error Resume Next
objApp.Visible = True
Err.Clear
End If
End Select
On Error GoTo 0
Set OffApp = objApp
Set objApp = Nothing
End Function