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 学习笔记_笑虾的博客-CSDN博客
　　VBA操作文件和文件夹步骤_w3cschool
　　VBA 收集 Word关键字批量处理-Excel版_笑虾的博客-CSDN博客_vba word 查找关键字