VBA 收集 Word关键字批量处理

批量对关键字打标记（文件夹遍历）

Option Explicit
Private Const FINISHED_FILE_PATH As String = "newData\"         ' 存完成文件的目录名
Private Const ERROR_FILE_PATH As String = "errorData\"          ' 存出错文件的目录名
Private Const SKIP_FILE_PATH As String = "skipData\"            ' 存跳过文件的目录名
Private Const ERROR_FILE_SUFFIX As String = "Err.log"           ' 出错日志后缀
Private Const SKIP_FILE_SUFFIX As String = "Skip.log"           ' 跳过日志后缀
Dim fs As Object                                                ' 文件系统对象
Dim errLogFile As String                                        ' 错误日志
Dim skipLogFile As String                                       ' 跳过记录的日志
Dim sourceFilePath As String                                    ' 选择要处理的文件所在
 
Sub 遍历文件夹中对文档的关键字打标记()
    On Error GoTo ErrorHandler
     
    Dim CurrPath$, CurrFile$, currDoc As Document, keyArray() As String, fileNameExtension As String, newPath As String, skipPath As String, errPath As String, tempFileName As String
    ' --------- 初始化 开始 ----------
    ' 选择要处理的文件所在
    If Not SelectFolder() Then Exit Sub
    If MsgBox("要处理的文件在：" & sourceFilePath, vbYesNo + vbInformation, "确认源文件目录") <> vbYes Then Exit Sub
    CurrPath = ThisDocument.path & "\"
    errLogFile = CurrPath & Replace(ThisDocument.Name, ".docm", ERROR_FILE_SUFFIX)
    skipLogFile = CurrPath & Replace(ThisDocument.Name, ".docm", SKIP_FILE_SUFFIX)
    ' 准备文件夹
    newPath = CurrPath & FINISHED_FILE_PATH
    skipPath = CurrPath & SKIP_FILE_PATH
    errPath = CurrPath & ERROR_FILE_PATH
    If Dir(newPath, vbDirectory) = vbNullString Then MkDir newPath
    If Dir(skipPath, vbDirectory) = vbNullString Then MkDir skipPath
    If Dir(errPath, vbDirectory) = vbNullString Then MkDir errPath
    ' 初始化文件系统对象
    Set fs = CreateObject("Scripting.FileSystemObject")
    ' --------- 初始化 结束 ----------
    
    CurrFile = Dir(sourceFilePath)

    Do Until CurrFile = ""
        If CurrFile <> ThisDocument.Name And (Right(CurrFile, 5) = ".docx" Or Right(CurrFile, 4) = ".doc") Then
            tempFileName = sourceFilePath & CurrFile
            Set currDoc = Documents.Open(tempFileName, Visible:=False)
            ' 找到关键字的，另存一份到 newPath 下
            If 对关键字打标记(currDoc, ThisDocument) Then
                currDoc.SaveAs2 FileName:=newPath & CurrFile, FileFormat:=wdFormatXMLDocument
                Kill tempFileName
                currDoc.Close wdDoNotSaveChanges
                Set currDoc = Nothing
                'DoEvents
            Else
                currDoc.Close wdDoNotSaveChanges
                Set currDoc = Nothing
                skiplog tempFileName
                Call moveFile(tempFileName, skipPath & CurrFile)
            End If    
        End If
NextFile:
        CurrFile = Dir()
    Loop
    
    Set fs = Nothing
    Call MsgBox("处理完毕", vbOKOnly + vbInformation, "温馨提示")
Exit Sub
ErrorHandler:
    errlog "================================================================================"
    errlog "【错误文件】" & tempFileName
    errlog Err.Number & ":" & Replace(Err.Description, vbLf, " vbCrLf ")
    Call moveFile(tempFileName, errPath & CurrFile)
    Resume NextFile
End Sub

写日志

' 写日志
Sub errlog(logMsg As String)
    Shell "cmd.exe /c echo " & Format(Now, "YYYY-MM-DD HH:MM:SS") & " ===》 " & logMsg & " >> " & errLogFile
End Sub

Sub skiplog(logMsg As String)
    Shell "cmd.exe /c echo " & logMsg & " >> " & skipLogFile
End Sub

移动文件

' 移动文件
Sub moveFile(sourcePath As String, targetPath As String)
    On Error GoTo ErrorHandler
    Call fs.moveFile(sourcePath, targetPath)
Error_Handler_Exit:
    Exit Sub
Exit Sub
ErrorHandler:
    errlog "================================================================================"
    errlog "【移动文件失败】" & sourcePath
    errlog Err.Number & ":" & Replace(Err.Description, vbLf, " vbCrLf ")
Resume Error_Handler_Exit
End Sub

选择目录

Function SelectFolder()
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisDocument.path & "\"
        If .Show = -1 Then ' OK返回 -1，Cancel 返回 0
            sourceFilePath = .SelectedItems(1) & "\"
            SelectFolder = True
        Else
            SelectFolder = False
        End If
    End With
End Function

对关键字打标记（查找替换）

注意：如果是 .Execute Replace:=wdReplaceOne (替换第一个), 那么 With doc.Content.Find 就要放到循环里面了。否则会出现意外的丢失情况！ ：比如：ABA先搜B，再搜A，替换的不是第一个A用是第二个A。未细研究根源，仅此备注。

Function 对关键字打标记(doc As Document, MainDoc As Document)
    Dim i As Integer, keyArrLen As Integer, keyArray() As String, styleName As String, edited As Boolean
    
    edited = False ' 默认未编辑状态
    keyArray = 获取关键字(MainDoc)
    keyArrLen = UBound(keyArray)
    styleName = 创建样式(doc)
   
    With doc.Content.Find
       .ClearFormatting
       .Replacement.ClearFormatting
       .Replacement.style = styleName
       .Replacement.Text = "^&"
       .Forward = True
       .Wrap = wdFindContinue
       ' 遍历查找关键字，并标示
        For i = 0 To keyArrLen
            .Text = keyArray(i)
            .Execute Replace:=wdReplaceAll
            ' 找到了关键字，标记为编辑过。
            If .Found Then
                edited = True
            End If
        Next
    End With
    
    对关键字打标记 = edited
End Function

创建样式

Function 创建样式(doc As Document)
    On Error Resume Next ' 出错时忽略，继续向下运行。
    ' 判断样式，不存在则创建
    Dim flag As Boolean, syte As style, styleName As String
    styleName = "关键字"
    
    flag = True
    For Each syte In doc.Styles
        If syte.NameLocal = styleName Then
            flag = False
        End If
    Next
    
    If flag Then
        doc.Styles.Add Name:=styleName, Type:=wdStyleTypeCharacter
        With doc.Styles(styleName).Font
            .NameFarEast = "微软雅黑"
            .Bold = True
            .Color = wdColorYellow
            .Shading.ForegroundPatternColor = wdColorAutomatic
            .Shading.BackgroundPatternColor = wdColorRed
        End With
    End If
    
    创建样式 = styleName
End Function

获取关键字（动态数组）

Function 获取关键字(doc As Document)
    Dim keyArray() As String, arrLen As Integer, pgs As Paragraphs, i As Integer
    ' 取当前文档所有段落
    Set pgs = doc.Paragraphs
    arrLen = pgs.Count - 1
    ' 重置动态数组的长度
    ReDim keyArray(arrLen) As String

    ' 遍历段落，将文字加入数组
    For i = 0 To arrLen
        keyArray(i) = Replace(Trim(pgs(i + 1).Range.Text), vbCr, "")
    Next

    获取关键字 = keyArray
End Function

参考资料

湖边的小屋圣迹 - Excel、Word VBA 学习笔记

MSDN - ReDim 语句：在 过程级别 用于重新分配动态数组 变量的存储空间。

w3cschool.cn VBA操作文件和文件夹步骤
VBA 收集 Word关键字批量处理-Excel版（升级版）