VBA收集Word关键字批量处理

　　批量对关键字打标记（文件夹遍历）OptionExplicitPrivateConstFINISHEDFILEPATHAsStringnewData存完成文件的目录名PrivateConstERRORFILEPATHAsStringerrorData存出错文件的目录名PrivateConstSKIPFILEPATHAsStringskipData存跳过文件的目录名PrivateConstERRORFILESUFFIXAsStringErr。log出错日志后缀PrivateConstSKIPFILESUFFIXAsStringSkip。log跳过日志后缀DimfsAsObject文件系统对象DimerrLogFileAsString错误日志DimskipLogFileAsString跳过记录的日志DimsourceFilePathAsString选择要处理的文件所在Sub遍历文件夹中对文档的关键字打标记（）OnErrorGoToErrorHandlerDimCurrPath，CurrFile，currDocAsDocument，keyArray（）AsString，fileNameExtensionAsString，newPathAsString，skipPathAsString，errPathAsString，tempFileNameAsString初始化开始选择要处理的文件所在IfNotSelectFolder（）ThenExitSubIfMsgBox（要处理的文件在：sourceFilePath，vbYesNovbInformation，确认源文件目录）vbYesThenExitSubCurrPathThisDocument。patherrLogFileCurrPathReplace（ThisDocument。Name，。docm，ERRORFILESUFFIX）skipLogFileCurrPathReplace（ThisDocument。Name，。docm，SKIPFILESUFFIX）准备文件夹newPathCurrPathFINISHEDFILEPATHskipPathCurrPathSKIPFILEPATHerrPathCurrPathERRORFILEPATHIfDir（newPath，vbDirectory）vbNullStringThenMkDirnewPathIfDir（skipPath，vbDirectory）vbNullStringThenMkDirskipPathIfDir（errPath，vbDirectory）vbNullStringThenMkDirerrPath初始化文件系统对象SetfsCreateObject（Scripting。FileSystemObject）初始化结束CurrFileDir（sourceFilePath）DoUntilCurrFileIfCurrFileThisDocument。NameAnd（Right（CurrFile，5）。docxOrRight（CurrFile，4）。doc）ThentempFileNamesourceFilePathCurrFileSetcurrDocDocuments。Open（tempFileName，Visible：False）找到关键字的，另存一份到newPath下If对关键字打标记（currDoc，ThisDocument）ThencurrDoc。SaveAs2FileName：newPathCurrFile，FileFormat：wdFormatXMLDocumentKilltempFileNamecurrDoc。ClosewdDoNotSaveChangesSetcurrDocNothingDoEventsElsecurrDoc。ClosewdDoNotSaveChangesSetcurrDocNothingskiplogtempFileNameCallmoveFile（tempFileName，skipPathCurrFile）EndIfEndIfNextFile：CurrFileDir（）LoopSetfsNothingCallMsgBox（处理完毕，vbOKOnlyvbInformation，温馨提示）ExitSubErrorHandler：errlogerrlog【错误文件】tempFileNameerrlogErr。Number：Replace（Err。Description，vbLf，vbCrLf）CallmoveFile（tempFileName，errPathCurrFile）ResumeNextFileEndSub写日志写日志Suberrlog（logMsgAsString）Shellcmd。execechoFormat（Now，YYYYMMDDHH：MM：SS）》logMsgerrLogFileEndSubSubskiplog（logMsgAsString）Shellcmd。execechologMsgskipLogFileEndSub移动文件移动文件SubmoveFile（sourcePathAsString，targetPathAsString）OnErrorGoToErrorHandlerCallfs。moveFile（sourcePath，targetPath）ErrorHandlerExit：ExitSubExitSubErrorHandler：errlogerrlog【移动文件失败】sourcePatherrlogErr。Number：Replace（Err。Description，vbLf，vbCrLf）ResumeErrorHandlerExitEndSub选择目录FunctionSelectFolder（）WithApplication。FileDialog（msoFileDialogFolderPicker）。InitialFileNameThisDocument。pathIf。Show1ThenOK返回1，Cancel返回0sourceFilePath。SelectedItems（1）SelectFolderTrueElseSelectFolderFalseEndIfEndWithEndFunction对关键字打标记（查找替换）
　　注意：如果是。ExecuteReplace：wdReplaceOne（替换第一个），那么Withdoc。Content。Find就要放到循环里面了。否则会出现意外丢失的情况！：比如：ABA先搜B，再搜A，替换的不是第一个A用是第二个A。未仔细研究根源，仅此备注。Function对关键字打标记（docAsDocument，MainDocAsDocument）DimiAsInteger，keyArrLenAsInteger，keyArray（）AsString，styleNameAsString，editedAsBooleaneditedFalse默认未编辑状态keyArray获取关键字（MainDoc）keyArrLenUBound（keyArray）styleName创建样式（doc）Withdoc。Content。Find。ClearFormatting。Replacement。ClearFormatting。Replacement。stylestyleName。Replacement。Text。ForwardTrue。WrapwdFindContinue遍历查找关键字，并标示Fori0TokeyArrLen。TextkeyArray（i）。ExecuteReplace：wdReplaceAll找到了关键字，标记为编辑过。If。FoundTheneditedTrueEndIfNextEndWith对关键字打标记editedEndFunction创建样式Function创建样式（docAsDocument）OnErrorResumeNext出错时忽略，继续向下运行。判断样式，不存在则创建DimflagAsBoolean，syteAsstyle，styleNameAsStringstyleName关键字flagTrueForEachsyteIndoc。StylesIfsyte。NameLocalstyleNameThenflagFalseEndIfNextIfflagThendoc。Styles。AddName：styleName，Type：wdStyleTypeCharacterWithdoc。Styles（styleName）。Font。NameFarEast微软雅黑。BoldTrue。ColorwdColorYellow。Shading。ForegroundPatternColorwdColorAutomatic。Shading。BackgroundPatternColorwdColorRedEndWithEndIf创建样式styleNameEndFunction获取关键字（动态数组）Function获取关键字（docAsDocument）DimkeyArray（）AsString，arrLenAsInteger，pgsAsParagraphs，iAsInteger取当前文档所有段落Setpgsdoc。ParagraphsarrLenpgs。Count1重置动态数组的长度ReDimkeyArray（arrLen）AsString遍历段落，将文字加入数组Fori0ToarrLenkeyArray（i）Replace（Trim（pgs（i1）。Range。Text），vbCr，）Next获取关键字keyArrayEndFunction参考资料
　　Excel、WordVBA学习笔记笑虾的博客CSDN博客
　　VBA操作文件和文件夹步骤w3cschool
　　VBA收集Word关键字批量处理Excel版笑虾的博客CSDN博客vbaword查找关键字