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

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 ErrorHandlerDim 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 SubIf MsgBox("要处理的文件在：" & sourceFilePath, vbYesNo + vbInformation, "确认源文件目录") <> vbYes Then Exit SubCurrPath = ThisDocument.path & "\"errLogFile = CurrPath & Replace(ThisDocument.Name, ".docm", ERROR_FILE_SUFFIX)skipLogFile = CurrPath & Replace(ThisDocument.Name, ".docm", SKIP_FILE_SUFFIX)' 准备文件夹newPath = CurrPath & FINISHED_FILE_PATHskipPath = CurrPath & SKIP_FILE_PATHerrPath = CurrPath & ERROR_FILE_PATHIf Dir(newPath, vbDirectory) = vbNullString Then MkDir newPathIf Dir(skipPath, vbDirectory) = vbNullString Then MkDir skipPathIf 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") ThentempFileName = sourceFilePath & CurrFileSet currDoc = Documents.Open(tempFileName, Visible:=False)' 找到关键字的，另存一份到 newPath 下If 对关键字打标记(currDoc, ThisDocument) ThencurrDoc.SaveAs2 FileName:=newPath & CurrFile, FileFormat:=wdFormatXMLDocumentKill tempFileNamecurrDoc.Close wdDoNotSaveChangesSet currDoc = Nothing'DoEventsElsecurrDoc.Close wdDoNotSaveChangesSet currDoc = Nothingskiplog tempFileNameCall moveFile(tempFileName, skipPath & CurrFile)End If    End If
NextFile:CurrFile = Dir()LoopSet fs = NothingCall MsgBox("处理完毕", vbOKOnly + vbInformation, "温馨提示")
Exit Sub
ErrorHandler:errlog "================================================================================"errlog "【错误文件】" & tempFileNameerrlog 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 SubSub skiplog(logMsg As String)Shell "cmd.exe /c echo " & logMsg & " >> " & skipLogFile
End Sub

移动文件

' 移动文件
Sub moveFile(sourcePath As String, targetPath As String)On Error GoTo ErrorHandlerCall fs.moveFile(sourcePath, targetPath)
Error_Handler_Exit:Exit Sub
Exit Sub
ErrorHandler:errlog "================================================================================"errlog "【移动文件失败】" & sourcePatherrlog 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 返回 0sourceFilePath = .SelectedItems(1) & "\"SelectFolder = TrueElseSelectFolder = FalseEnd IfEnd 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 Booleanedited = 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 Thenedited = TrueEnd IfNextEnd With对关键字打标记 = edited
End Function

创建样式

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

获取关键字（动态数组）

Function 获取关键字(doc As Document)Dim keyArray() As String, arrLen As Integer, pgs As Paragraphs, i As Integer' 取当前文档所有段落Set pgs = doc.ParagraphsarrLen = pgs.Count - 1' 重置动态数组的长度ReDim keyArray(arrLen) As String' 遍历段落，将文字加入数组For i = 0 To arrLenkeyArray(i) = Replace(Trim(pgs(i + 1).Range.Text), vbCr, "")Next获取关键字 = keyArray
End Function

参考资料

湖边的小屋圣迹 - Excel、Word VBA 学习笔记
w3cschool.cn VBA操作文件和文件夹步骤
VBA 收集 Word关键字批量处理-Excel版（升级版）

VBA 收集 Word关键字批量处理相关推荐

vba 压缩图片_1分钟批量处理100张图片，Word图片批量压缩/提取/居中统统搞定
天下苦Word久矣!Word不仅是个码字工具,还是个排版工具,而Word在排版方面经常遇到的问题,恐怕说个三天三夜都说不完! 好不容易做完了100页的活动方案,交到处女座上司那里,他告诉我:" ...
word(2010)使用VBA完成批处理操作-批量清除表格某单元格内容
word VBA 的使用案例 VBA是什么? 为什么要使用VBA? VBA的运用实例---批量清除表格某单元格内容结语 VBA是什么? VBA(Visual Basic for Applicatio ...
vba 保存word里面的图片_1分钟批量处理100张图片，有Word在
天下苦Word久矣!Word不仅是个码字工具,还是个排版工具,而Word在排版方面经常遇到的问题,恐怕说个三天三夜都说不完! 好不容易做完了100页的活动方案,交到处女座上司那里,他告诉我:" ...
如何用word写书_如何用vba在word中添加打勾的方框？
最近在做word vba项目,遇到个需求,需要根据条件判断批量输出打√的方框和不打√的方框,类似如下图所示: 本来以为是个很容易的事情,没想到阻碍不小. 首先,我们先看看如何在word文档中手动输入带 ...
【python脚本】word批注批量提取器V2实用版
目录前言实用演示关键技术 python调用VBA python写excel 打开excel 独立线程资源链接前言在经历了VBA提取word批注: [VBA脚本]提取word文档中所有批注的 ...
如何用vba在word中快速移动或选中内容区域？
转自:http://www.exceloffice.net/archives/1598 在word中经常需要操作特定位置的文本内容,定位文本内容就显得尤为重要. 在word vba中Range. Se ...
【MS Word技巧】word如何批量把括号内字体变绿？
word如何批量把括号内字体变绿? 如果是单个括号内的内容,就直接选中内容,按ctrl+d组合键设置字体颜色为红色即可如果是多个括号内的内容时分两种情况,如下: 当是英文括号时: ctrl+h调出替 ...
VBA读取html表格内容,科学网—VBA读取word文档表格中table的cell的text文本 - 付安民的博文...
VBA读取word文档表格中table的cell的text文本已有 11546 次阅读 2010-6-4 16:40 |个人分类:学习篇|系统分类:科研笔记 Sub Readtable() Dim ...
xdf文件改word_真正Txt 文本文件和Doc Word文件批量互转工具
电近经常上网下载小说文本,电脑里一大堆,虽然文本文件简洁方便,可是用记事本打开阅读,眼睛看起来却很累,还是觉得保存为WORD文件,阅读起来更舒服,也许一个两个TXT文本,转换成WORD,我们直接打开复 ...

VBA 收集 Word关键字批量处理