locked
Word VBA for batch find-replace with reference to Excel RRS feed

  • Question

  • Hello! My task to perform is as follows: I have a batch of Word files that I want to perform batch find-replacing on. I put all my Word files in a folder on desktop;  I also put an Excel file on desktop, which contains my find-replace list: word to find in column 1, and word for replacing with in column 2.

    I have used the following code in the past and it worked well. However, after I switched to a new desktop and working remotely, it stopped working. It would also make my Excel locked by myself. 

    Below is my code. Could anyone help me find the problem? Thanks in advance!  

    Sub myBatchWork()
        Dim xApp As Object 
        Dim xBook As Object 
        Dim xSheet As Object 
        Dim xRng As Object 
        Dim xCol As Object 

        Set xApp = CreateObject("Excel.Application")
        Set xBook = xApp.Workbooks.Open("c:\users\myName\Desktop\myList.xlsx")
        Set xSheet = xBook.Sheets(1)
        Set xRng = xSheet.Range("A1", xSheet.Range("A1").End(xlDown))

        Dim file
        Dim path As String

        path = "c:\users\myName\Desktop\myFolder\"
        file = Dir(path & "*.docx")

        Do While file <> ""
        Documents.Open FileName:=path & file

        For Each xCol In xRng
            Call macro1(xCol.Value, xCol.Offset(0, 1).Value)
        Next

        ActiveDocument.Save
        ActiveDocument.Close

        file = Dir()
        Loop
    End Sub

    Sub macro1(findText$, replaceText$)

        Selection.Find.ClearFormatting

        Selection.Find.Replacement.ClearFormatting

        With Selection.Find

            .Text = findText

            .Replacement.Text = replaceText

            .Forward = True

            .Wrap = wdFindContinue

            .Format = False

            .MatchCase = False

            .MatchWholeWord = False

            .MatchWildcards = False

            .MatchSoundsLike = False

            .MatchAllWordForms = False

        End With

        Selection.Find.Execute Replace:=wdReplaceAll

        Selection.Find.Execute

    End Sub

    Friday, September 4, 2020 10:59 PM

All replies

  • Based on your code, which suggests the workbook in Desktop and the documents in a sub folder 'Myfolder', the following should work and make all the changes.

    Option Explicit

    Sub myBatchWork()
    'Graham Mayor - https://www.gmayor.com - Last updated - 05 Sep 2020
    Dim xApp As Object
    Dim xBook As Object
    Dim xSheet As Object
    Dim LastRow As Integer, iRow As Integer
    Dim sPath As String
    Dim sDoc As String
    Dim oDoc As Document
    Dim RetVal As Boolean
    Dim FSO As Object
    Const sWorkbook As String = "myList.xlsx"

        sPath = Environ("USERPROFILE") & "\Desktop\"

        On Error Resume Next
        Set xApp = GetObject(, "Excel.Application")
        If Err Then
            Set xApp = CreateObject("Excel.Application")
        End If
        On Error GoTo 0

        For Each xBook In xApp.Workbooks
            If xBook.Name = sWorkbook Then
                RetVal = True
                Exit For
            End If
        Next
        If RetVal = False Then
            Set FSO = CreateObject("Scripting.FileSystemObject")
            If FSO.FileExists(sPath & sWorkbook) Then
                Set xBook = xApp.Workbooks.Open(FileName:=sPath & sWorkbook)
            Else
                MsgBox "The Excel file" & vbCr & sPath & sWorkbook & vbCr & "does not exist", vbCritical
                GoTo lbl_Exit
            End If
        End If
        xApp.Visible = True

        Set xSheet = xBook.Sheets(1)
        LastRow = xSheet.Range("A" & xSheet.Rows.Count).End(-4162).Row
        sDoc = Dir(sPath & "myfolder\" & "*.docx")

        Do While sDoc <> ""
            Set oDoc = Documents.Open(FileName:=sPath & "myfolder\" & sDoc)
            For iRow = 1 To LastRow
                'Debug.Print xSheet.Range("A" & iRow)
                Call ReplaceWords(oDoc, xSheet.Range("A" & iRow), xSheet.Range("A" & iRow).Offset(0, 1).value)
            Next
            oDoc.Save
            oDoc.Close
            sDoc = Dir()
        Loop
        xApp.Quit
    lbl_Exit:
        Set FSO = Nothing
        Set xApp = Nothing
        Set xBook = Nothing
        Set xSheet = Nothing
        Set oDoc = Nothing
        Exit Sub
    End Sub

    Sub ReplaceWords(oDoc As Document, findText$, replaceText$)
        With oDoc
            Selection.HomeKey wdStory
            Selection.Find.ClearFormatting
            Selection.Find.Replacement.ClearFormatting
            With Selection.Find
                .Text = findText
                .Replacement.Text = replaceText
                .Forward = True
                .Wrap = wdFindContinue
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
            End With
            Selection.Find.Execute Replace:=wdReplaceAll
            Selection.Find.Execute
        End With
    End Sub


    Graham Mayor - Word MVP
    www.gmayor.com



    Saturday, September 5, 2020 4:20 AM
  • Thank you very much, Graham. You code works great for me!

    Still, I am quite curious about why my code stopped working, if you could give me some thoughts? Thanks again.

    Wednesday, September 30, 2020 8:20 PM