VBA：结合查找替换批量检索关键词

最新推荐文章于 2025-03-13 11:55:44 发布

VBA-守候

最新推荐文章于 2025-03-13 11:55:44 发布

阅读量2.5k

点赞数 3

分类专栏： VBA办公自动化文章标签： vba msword 自动化编程语言开发语言

本文链接：https://blog.csdn.net/qq_64613735/article/details/125862131

版权

VBA办公自动化专栏收录该内容

21 篇文章

订阅专栏

注意：因为此问题可以结合大学日常用得较多的Excel，作为存储多个关键词的载体。此文便在Excel中写代码，也方便操作。

一、问题假设

1.待处理文件

假如现在有一个文件夹，里面有一篇Word文档（右）；需要检索的词记录在相同文件夹下的另一个Excel工作簿中的Sheet1这张表格的A列（左，第一行是标题，不参与检索），即查找的内容，替换的内容为第B列，C列可以选择是否用通配符替换。

2.假设处理要求

需要将上图所有Word文件中包含Excel表格里的关键词所地方左右加上中括号。

二、关键思路

1.遍历Excel单元格

遍历存放多个关键词的Excel表格“关键词.xlsx”的Sheet1的A列的单元格。

2.Word中查找替换

每个单元格的值作为Word查找的内容，在Word中将查找到的区域标记在中括号内。

参数设置：

这里前面两个关键词用的是不勾选通配符替换，第三个是通配符替换，有时写法上可能稍有差别。

关于Word（通配符）替换的内容，可以关注我的专栏

Word（通配符）替换https://www.zhihu.com/column/c_1517437402993397760

了解之前收录的更多典型示例。

三、参考代码

Rem 此处以下为主程序
Sub Word批量替换()
    Dim sht As Worksheet
    Dim wdApp As Object
    Dim fd As FileDialog
    Dim fso As Object
    Dim fName
    Dim aDoc
    Dim arr
    
    Set sht = ThisWorkbook.Sheets("sheet1")
    Set wdApp = CreateObject("Word.Application")
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    Set fso = CreateObject("Scripting.FileSystemObject")
    arr = sht.Cells(1, 1).CurrentRegion
    
    With fd
        .AllowMultiSelect = True
        .InitialFileName = ThisWorkbook.Path
        .Title = "选择Word文件（可多选）"
        .Filters.Clear
        .Filters.Add "所有文件", "*.*", 1
        .Filters.Add "Word文件", "*.doc*;*.dot*", 2
        If .Show Then
            Application.ScreenUpdating = False
            For Each fName In .SelectedItems
            
                On Error Resume Next
                
                If fso.GetExtensionName(fName) Like "do[ct]*" And Not fName Like "*~$*" Then
                    Set aDoc = wdApp.Documents.Open(fName)
                    For i = LBound(arr, 1) + 1 To UBound(arr, 1)
                        Call 处理过程(aDoc, CStr(arr(i, 1)), CStr(arr(i, 2)), CBool(arr(i, 3)))
                    Next
                    aDoc.Close -1
                    j = j + 1
                    Debug.Print j, fName, "处理完成"
                End If
            Next
            Application.ScreenUpdating = True
        End If
    End With
    
    Set sht = Nothing
    Set fd = Nothing
    Set wdApp = Nothing
    Set fso = Nothing
    Set aDoc = Nothing
    
    MsgBox Format(j, "完成 共处理了0个Word文件")
End Sub

Rem 此处以下为替换过程
Sub 处理过程(aDoc, findText As String, Optional replaceText As String = "^&", Optional wildCards As Boolean = False)

    On Error GoTo err1
    
    With aDoc.Content.Find
        .ClearFormatting
        .Forward = True
        .Wrap = 0
        .MatchWildCards = wildCards
        .Text = findText
        .Replacement.ClearFormatting
        .Replacement.Text = replaceText
        .Execute Replace:=2
    End With

    Exit Sub
    
err1:
    Debug.Print Err.Description
End Sub