可用于批量替换文件夹中所有word的关键字的宏代码(可保留原格式)

使用说明

** 一、在word工具栏找到开发工具，在开发工具中点击Visual Basic**

如果工具栏中没有开发工具这一个功能区，需要点击工具栏中的文件→选项→自定义功能区，将开发工具勾选。

1. 

2. 

3. 
   二、在点击Visual Basic后，在Normal处右键→插入→模块

在弹出的文本框中复制宏代码并进行保存，宏代码就可以使用了
三、使用时点击工具栏中的开发工具→宏→选择哪个宏→运行，根据对话框输入相应文字

**当前文档的宏里应该有这两个宏，如果没有需要根据流程加载一下。**文件提取密码：fi4t

批量替换宏的演示：

宏的名称为AdvancedReplaceIncludingHeaders
预处理的文件夹为桌面的“批量替换查找演示”文件夹，文件夹内部有5个word文档，包括了页眉、页脚、表格格式的ACT内容，演示批量替换宏使QAQ文字改为NBA

1.点击word工具栏中的开发工具→宏→选中AdvancedReplaceIncludingHeaders→运行

2.弹出第一个对话框，这里输入需要替换的文字“QAQ”，点击确定

3.弹出第二个对话框，这里输入替换后的问题“NBA”，点击确定

4.弹出第三个对话框，选择是否区分大小写

5.弹出第四个对话框，选择是否全字匹配
（一般选择否，如果选择是，则会出现文本为apple，查找ap会显示查找不到的情况）

6.弹出第五个对话框，选择文件夹
随后宏开始运行，等待替换

批量查找宏的演示：

宏的名称为SearchTextInAllWordDocuments

1.点击word工具栏中的开发工具→宏→选中SearchTextInAllWordDocuments→运行

2.弹出对话框，是否需要区分大小写

3.弹出对话框，选择文件夹。
随后宏开始运行，等待查找

批量替换宏代码

Sub AdvancedReplaceIncludingHeaders()
    Dim folderPath As String, filePath As String
    Dim doc As Document, rng As Range
    Dim keyword1 As String, keyword2 As String
    Dim matchCase As Boolean, matchWholeWord As Boolean
    Dim originalFont As Font
    Dim replaceCount As Long, fileCount As Long
    Dim startTime As Double, resultMsg As String
    
    ' 用户输入
    keyword1 = InputBox("请输入要替换的文本：", "旧文本", "")
    If keyword1 = "" Then Exit Sub
    
    keyword2 = InputBox("请输入替换后的文本：", "新文本", "")
    If keyword2 = "" Then Exit Sub
    
    ' 搜索选项
    matchCase = (MsgBox("是否区分大小写？", vbQuestion + vbYesNo, "搜索选项") = vbYes)
    matchWholeWord = (MsgBox("是否全字匹配？", vbQuestion + vbYesNo, "搜索选项") = vbYes)
    
    ' 选择文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择包含Word文档的文件夹"
        If .Show <> -1 Then Exit Sub
        folderPath = .SelectedItems(1) & "\"
    End With
    
    ' 初始化
    startTime = Timer
    filePath = Dir(folderPath & "*.doc*")
    Application.ScreenUpdating = False
    
    ' 主处理循环
    Do While filePath <> ""
        fileCount = fileCount + 1
        On Error Resume Next
        Set doc = Documents.Open(folderPath & filePath, ReadOnly:=False, Visible:=False)
        
        If Err.Number = 0 Then
            replaceCount = 0
            
            ' 1. 替换主文档内容
            replaceCount = replaceCount + ReplaceInRange(doc.Content, keyword1, keyword2, matchCase, matchWholeWord)
            
            ' 2. 替换所有页眉
            Dim sec As section, hdr As HeaderFooter
            For Each sec In doc.Sections
                For Each hdr In sec.Headers
                    If hdr.Exists Then
                        replaceCount = replaceCount + ReplaceInRange(hdr.Range, keyword1, keyword2, matchCase, matchWholeWord)
                    End If
                Next hdr
                
                ' 3. 替换所有页脚
                For Each hdr In sec.Footers
                    If hdr.Exists Then
                        replaceCount = replaceCount + ReplaceInRange(hdr.Range, keyword1, keyword2, matchCase, matchWholeWord)
                    End If
                Next hdr
            Next sec
            
            ' 保存并记录结果
            doc.Close SaveChanges:=wdSaveChanges
            resultMsg = resultMsg & filePath & " - 替换 " & replaceCount & " 处" & vbCrLf
        Else
            resultMsg = resultMsg & filePath & " - [打开失败]" & vbCrLf
            Err.Clear
        End If
        On Error GoTo 0
        filePath = Dir()
    Loop
    
    ' 显示结果
    Application.ScreenUpdating = True
    timeUsed = Format((Timer - startTime) / 86400, "hh:mm:ss")
    
    MsgBox "替换完成！" & vbCrLf & _
           "处理文件: " & fileCount & " 个" & vbCrLf & _
           "总耗时: " & timeUsed & vbCrLf & vbCrLf & _
           "===== 详细结果 =====" & vbCrLf & resultMsg, _
           vbInformation, "批量替换报告"
End Sub

' 辅助函数：在指定范围内替换文本并保留格式
Function ReplaceInRange(rng As Range, findText As String, replaceText As String, _
                       matchCase As Boolean, matchWholeWord As Boolean) As Long
    Dim count As Long
    Dim originalFont As Font
    
    With rng.Find
        .ClearFormatting
        .Text = findText
        .Replacement.Text = replaceText
        .Forward = True
        .Wrap = wdFindStop
        .matchCase = matchCase
        .matchWholeWord = matchWholeWord
        .MatchWildcards = False
        
        Do While .Execute
            ' 保存原格式
            Set originalFont = rng.Font.Duplicate
            ' 执行替换
            rng.Text = replaceText
            ' 恢复原格式
            rng.Font = originalFont
            count = count + 1
            ' 移动范围继续查找
            rng.Collapse wdCollapseEnd
        Loop
    End With
    
    ReplaceInRange = count
End Function

批量查找宏代码

Sub SearchTextInAllWordDocuments()
    Dim folderPath As String
    Dim searchText As String
    Dim fso As Object
    Dim folder As Object
    Dim file As Object
    Dim wordDoc As Word.Document
    Dim fileCount As Integer
    Dim foundCount As Integer
    Dim resultMsg As String
    Dim totalFilesWithText As Integer
    Dim totalOccurrences As Integer
    Dim matchCase As Boolean
    Dim response As Integer
    
    ' 询问是否区分大小写
    response = MsgBox("搜索时是否区分大小写？", vbQuestion + vbYesNo, "区分大小写")
    matchCase = (response = vbYes)
    
    ' 让用户选择文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "请选择要搜索的文件夹"
        If .Show = -1 Then
            folderPath = .SelectedItems(1)
        Else
            MsgBox "未选择文件夹，操作已取消。", vbInformation
            Exit Sub
        End If
    End With
    
    ' 让用户输入要搜索的文字
    searchText = InputBox("请输入要搜索的文字:", "搜索内容")
    If searchText = "" Then
        MsgBox "未输入搜索文字，操作已取消。", vbInformation
        Exit Sub
    End If
    
    ' 初始化文件系统对象
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(folderPath)
    
    ' 初始化结果变量
    fileCount = 0
    totalFilesWithText = 0
    totalOccurrences = 0
    resultMsg = "搜索结果：" & vbCrLf & vbCrLf
    
    ' 显示搜索选项
    resultMsg = resultMsg & "搜索选项：" & vbCrLf & _
                "区分大小写: " & IIf(matchCase, "是", "否") & vbCrLf & vbCrLf
    
    ' 遍历文件夹中的所有文件
    For Each file In folder.Files
        ' 只处理Word文档（.doc, .docx）
        If LCase(fso.GetExtensionName(file.Name)) = "doc" Or _
           LCase(fso.GetExtensionName(file.Name)) = "docx" Then
           
            fileCount = fileCount + 1
            foundCount = 0
            
            ' 打开文档
            Set wordDoc = Documents.Open(file.Path, ReadOnly:=True, Visible:=False)
            
            ' 搜索文字
            With wordDoc.Content.Find
                .Text = searchText
                .matchCase = matchCase ' 使用用户选择的区分大小写选项
                .matchWholeWord = False
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
                .Forward = True
                .Wrap = wdFindStop
                
                Do While .Execute
                    foundCount = foundCount + 1
                Loop
            End With
            
            ' 记录结果
            If foundCount > 0 Then
                resultMsg = resultMsg & file.Name & ": " & foundCount & " 处" & vbCrLf
                totalFilesWithText = totalFilesWithText + 1
                totalOccurrences = totalOccurrences + foundCount
            End If
            
            ' 关闭文档
            wordDoc.Close SaveChanges:=False
        End If
    Next file
    
    ' 显示结果
    resultMsg = resultMsg & vbCrLf & "统计结果：" & vbCrLf & _
                "搜索文件夹: " & folderPath & vbCrLf & _
                "搜索内容: " & searchText & vbCrLf & _
                "区分大小写: " & IIf(matchCase, "是", "否") & vbCrLf & _
                "总文件数: " & fileCount & vbCrLf & _
                "包含搜索内容的文件数: " & totalFilesWithText & vbCrLf & _
                "总出现次数: " & totalOccurrences
    
    MsgBox resultMsg, vbInformation, "搜索完成"
    
    ' 清理对象
    Set wordDoc = Nothing
    Set folder = Nothing
    Set fso = Nothing
End Sub

' 辅助函数：IIf函数模拟
Function IIf(expr As Boolean, trueVal As Variant, falseVal As Variant) As Variant
    If expr Then
        IIf = trueVal
    Else
        IIf = falseVal
    End If
End Function