DEV Community

John Ding
John Ding

Posted on

VBA to replace a word in multiple MS word files

https://www.msofficeforums.com/word-vba/16209-run-macro-multiple-docx-files.html#post47785

`Sub RunMacroOnAllFilesInFolder()
Dim flpath As String, fl As String
flpath = InputBox("Please enter the path to the folder you want to run the macro on.")
If flpath = "" Then Exit Sub

If Right(flpath, 1) <> Application.PathSeparator Then flpath = flpath & Application.PathSeparator
fl = Dir(flpath & "*.docx")
Application.ScreenUpdating = False
Do Until fl = ""
MyMacro flpath, fl
fl = Dir
Loop
End Sub

Sub MyMacro(flpath As String, fl As String)
Dim doc As Document
Set doc = Documents.Open(flpath & fl)
'Do stuff
doc.Save
doc.Close SaveChanges:=False

End Sub `

Sub GlobalTextReplacement()
' Root under which all manuals are stored
Dim rootPath As String
rootPath = "c:\Data\Manuals\"

' Find and replace text for wildcard replacement. Performed first.
Dim findTextsWild() As Variant, replaceTextsWild() As Variant
findTextsWild = Array("[ ]{2;}", "[cC]onfiguration[/ ]@[pP]olicy [rR]epository", "[sS]ervlet[- ]@[fF]ilter")
replaceTextsWild = Array(" ", "Configuration/Policy Repository", "Servlet-Filter")

' Find and replace text for normal case insensitive replacement. Performed second.
Dim findTexts() As Variant, replaceTexts() As Variant
findTexts = Array("DirX Access", "Policy Repository", "User Repository", "Servlet", "servletfilter", "SAML assertion", "DirX Access Server", "DirX Access Manager", "Deployment Manager", "Policy Manager", "Client SDK", "^p ", " ^p")
replaceTexts = Array("DirX Access", "Policy Repository", "User Repository", "Servlet", "Servlet-Filter", "SAML assertion", "DirX Access Server", "DirX Access Manager", "Deployment Manager", "Policy Manager", "Client SDK", "^p", "^p")

' Main code
Application.ScreenUpdating = False

Dim dirNames(20) As String
Dim dirNamesCount As Integer
dirNamesCount = 0

Dim dirName As String
dirName = Dir$(rootPath & "*", vbDirectory)
Do Until LenB(dirName) = 0
Dim dirPath As String
dirPath = rootPath & dirName
If ((GetAttr(dirPath) And vbDirectory) = vbDirectory) And (dirName <> ".") And (dirName <> "..") Then
dirNamesCount = dirNamesCount + 1
dirNames(dirNamesCount) = dirPath & "\"
End If
dirName = Dir$
Loop

Do While dirNamesCount > 0
Dim fileName As String
dirName = dirNames(dirNamesCount)
dirNamesCount = dirNamesCount - 1
fileName = Dir$(dirName & "*.doc", vbDirectory)
Do Until LenB(fileName) = 0
Dim filePath As String
filePath = dirName & fileName
fileName = Dir$

    Dim document As document
    Set document = Documents.Open(filePath)
    document.TrackRevisions = True

    document.Select

    Dim i As Integer, maxIndex As Integer
    maxIndex = UBound(findTextsWild)
    For i = LBound(findTextsWild) To maxIndex
        With Selection.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Text = findTextsWild(i)
            .Replacement.Text = replaceTextsWild(i)
            .Execute Replace:=wdReplaceAll, Forward:=True, _
                Wrap:=wdFindContinue, MatchWildcards:=True
        End With
    Next

    maxIndex = UBound(findTexts)
    For i = LBound(findTexts) To maxIndex
        With Selection.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Text = findTexts(i)
            .Replacement.Text = replaceTexts(i)
            .Execute Replace:=wdReplaceAll, Forward:=True, _
                Wrap:=wdFindContinue, MatchCase:=False, MatchWildcards:=False
        End With
    Next

    document.Save
    document.Close
Loop
Enter fullscreen mode Exit fullscreen mode

Loop

Application.ScreenUpdating = True
End Sub

Top comments (0)