In Worddokumenten Wörter ersetzen - Liste in Excel...

Frage:

In allen Worddokumenten - optional auch nur in bestimmten Worddateien mit Dateiauswahldialog - sollen Wörter ersetzt werden. Die Liste der alten bzw. neuen Wörter ist in Excel in den Spalten B und C. Wie geht das?
In all Word documents - also only in certain Word files with file selection dialog - words should be replaced. The list of old and new words is in an Excel file in columns B and C. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
In Worddokumenten Wörter ersetzen - Liste in Excel...[ZIP 50 KB]

Option Explicit
Const wdreplaceAll = 2
Dim blnTMP As Boolean
'-------------------------------------------------------------------------- 
' Module    : AllFiles 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 18.12.2012 
' Purpose   : In Worddokumenten Wörter ersetzen - Liste in Excel... 
'-------------------------------------------------------------------------- 
Public Sub Main()
    ' Dimensionieren der Variablen 
    Dim wksSheet As Worksheet
    Dim objDocument As Object
    Dim lngLastRow As Long
    Dim strDatei As String
    Dim strPath As String
    Dim objApp As Object
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' Pfad anpassen - fester Pfad vorgeben 
    'strPath = "C:\Temp\Word\" 
    ' Pfad anpassen - Worddateien sind im gleichen 
    'Verzeichnis wie diese Exceldatei 
    strPath = ThisWorkbook.Path & Application.PathSeparator
    Set objApp = OffApp("Word")
    ' Word nicht sichtbar 
    'Set objApp = OffApp("Word", False) 
    If Not objApp Is Nothing Then
        ' Tabellenblattname gegebenenfalls anpassen 
        Set wksSheet = ThisWorkbook.Worksheets("Tabelle1")
        ' Erste Worddatei in die Variable holen 
        strDatei = Dir$(strPath & "*.doc*", vbDirectory)
        ' Mach das so lange, bis keine Worddatei mehr da ist 
        Do While strDatei <> ""
            ' Worddokument öffnen 
            Set objDocument = objApp.Documents.Open _
                (strPath & strDatei)
            ' 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, 3).Value
                    ' Tu es! 
                    .Execute Replace:=wdreplaceAll
                End With
            Next lngLastRow
            ' Worddokument MIT speichern schliessen 
            objDocument.Close True
            ' Die nächste Datei nehmen 
            strDatei = Dir$()
            ' Objektvariable leeren 
            Set objDocument = Nothing
        Loop
    Else
        MsgBox "Application not installed!"
    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
Code gehört in das Modul "SomeFiles"
Option Explicit
Const wdreplaceAll = 2
Dim blnTMP As Boolean
'-------------------------------------------------------------------------- 
' Module    : SomeFiles 
' Procedure : Main_1 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 18.12.2012 
' Purpose   : In Worddokumenten Wörter ersetzen - Liste in Excel... 
'-------------------------------------------------------------------------- 
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:="Word-Dateien (*.doc*), *.doc*", _
        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("Word")
        ' Word nicht sichtbar 
        'Set objApp = OffApp("Word", 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)
                ' Worddokument öffnen 
                Set objDocument = objApp.Documents.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, 3).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

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...