使用Office内置的VBA编辑器实现WORD文档的批量查找替换

最近同事因为工作原因需要批量修改几百个WORD文档中的内容，并且是批量的重复性工作。如果按一个个文件打开，是一个繁琐、乏味且又容易遗漏出错的事儿，所以他想找一个能提供批量替换操作的工具，百度上有很多类似的Office插件，但都是收费的。

鉴于所有此类的工具都是基于Office提供的自动化完成的，所以我使用了Word内置的VBA编辑器编写了宏来实现这一功能。

首先在Word的文件->选项->自定义功能区中勾选右侧“主选项卡”中的“开发工具”后点击确定。

然后选择“开发工具”选项卡下的“Visual Basic”。

点击“插入”菜单中的“用户窗体”

 按下图添加控件，并修改对应的文本属性

 双击控件添加代码如下

Public filecount As Integer '文件总数
Public proccount As Integer '已经打开的数量
Public recount As Integer '已替换的数量
'替换文本
Function WordReplaces(FileName As String, SearchString As String, ReplaceString As String)
     On Error Resume Next
    Dim wdoc As Document
    Set wdoc = Word.Documents.Open(FileName)
    Dim wrnd As Range
    Set wrnd = wdoc.Range
    wrnd.Select
    With wrnd.Find
        .Text = SearchString
        .MatchCase = False
        .Wrap = wdFindContinue
        .Replacement.Text = ReplaceString
    End With
    If wrnd.Find.Execute(, , , , , , , , , , wdReplaceAll) Then
        recount = recount + 1
    End If
    wdoc.Save
    wdoc.Close
End Function
'枚举文件
Function FilesTree(ByVal sPath As String, ByVal sSearch As String, ByVal sReplace As String)
    On Error Resume Next
    Set oFso = CreateObject('Scripting.FileSystemObject')
    Set oFolder = oFso.GetFolder(sPath)
    Set oSubFolders = oFolder.SubFolders
    Set oFiles = oFolder.Files
    For Each oFile In oFiles
       If UCase(Right(oFile.Name, 5)) = '.DOCX' Or UCase(Right(oFile.Name, 4)) = '.DOC' Then
       proccount = proccount + 1
       Me.Label5.Caption = oFile.Path
        Me.Label6.Caption = Str(proccount)
        Label8.Width = proccount / filecount * Me.Frame3.Width
        Label8.Caption = Str(Int(proccount / filecount * 100)) & '%'
        Label8.TextAlign = fmTextAlignCenter
        Label12.Caption = Str(recount)
       DoEvents
        Call WordReplaces(oFile.Path, sSearch, sReplace)
        DoEvents
       End If
    Next
    For Each oSubFolder In oSubFolders
          Call FilesTree(oSubFolder.Path, sSearch, sReplace)
    Next
    Set oFolder = Nothing
    Set oSubFolders = Nothing
    Set oFso = Nothing
End Function
'计算总文件数
Function EnumFilesCount(ByVal sPath As String)
    On Error Resume Next
    Set oFso = CreateObject('Scripting.FileSystemObject')
    Set oFolder = oFso.GetFolder(sPath)
    Set oSubFolders = oFolder.SubFolders
    Set oFiles = oFolder.Files
    For Each oFile In oFiles
       If UCase(Right(oFile.Name, 5)) = '.DOCX' Or UCase(Right(oFile.Name, 4)) = '.DOC' Then
            filecount = filecount + 1
       End If
    Next
    For Each oSubFolder In oSubFolders
          Call EnumFilesCount(oSubFolder.Path)
    Next
    Set oFolder = Nothing
    Set oSubFolders = Nothing
    Set oFso = Nothing
End Function
'打开目录
Private Sub CommandButton1_Click()
    On Error Resume Next
    Dim objpath As String
    Set objshell = CreateObject('Shell.Application')
    Set objfolder = objshell.BrowseForFolder(0, '选择一个文件夹', 0)
    Set objfolderitem = objfolder.Self
        objpath = objfolderitem.Path
        If objpath <> '' Then
            TextBox1.Text = objpath
        End If
End Sub
'替换
Private Sub CommandButton2_Click()
    If Trim(Me.TextBox1.Text) = '' Or Me.TextBox2.Text = '' Then
        MsgBox '文件夹路径和查找的内容不能为空！'
    Else
        filecount = 0
        proccount = 0
        recount = 0
        EnumFilesCount (Me.TextBox1.Text)
        Me.Label6.Caption = '0'
        Me.Label10.Caption = Str(filecount)
        Call FilesTree(Me.TextBox1.Text, Me.TextBox2.Text, Me.TextBox3.Text)
        MsgBox '替换完成'
    End If
End Sub

点击工具栏运行按钮

 现在您就可以轻松快速的完成批量替换操作啦！

 已经编辑好的WORD宏文档也可在我的资源中下载。