(完整版)用VBA实现批量修改多个Word文档内容

用vba实现多个word文档里的多个内容进行批量更改说明：本方法思路是借用excel的表格对多个内容进行界面管理，再用excel的vba调用word文件进行查找更改。使用方法：将以下内容（不包括本句）复制进excel的宏模块，保存，然后excel界面设置如下：输入数据，运行宏就可以了。（若需要现成的excel文件，请单独下载）注：版权所有严禁转载Sub更新录入()Dima,b,zhszhs=Sheet1.Range(c&Rows.Count).End(xlUp).Rowp=ThisWorkbook.Path&\IfSheet1.Range(c5).Value=Thenwjj=新文书Elsewjj=Sheet1.Range(c5).ValueEndIfIfzhs3ThenCreateObject(Wscript.shell).popup没有数据可以录入,请输入数据后再点击生成新文档！,1,提示！,0+32ExitSubEndIfIfSheet1.Range(F1)修改本级文档ThenOnErrorResumeNextSetofso=CreateObject(Scripting.FileSystemObject)'生成文件夹ofso.CreateFolder(p&wjj)OnErrorGoTo0'替换本级或生成新的ElseIfMsgBox(是否替换本级文件夹内文档？,vbYesNo,提示)=vbNoThen:ExitSubElsewjj=EndIfApplication.ScreenUpdating=FalseWithCreateObject(Word.Application).Visible=Falsef=Dir(p&*.doc)DoWhilefi=i+1.Documents.Openp&fForb=3TozhsIfSheet1.Range(C&b)Then'有数据才替换.Selection.HomeKeyUnit:=6'到文档开始地方DoWhile.Selection.Find.Execute(Sheet1.Range(B&b))'查找s.Selection.Font.Color=wdColorAutomatic'字体颜色.Selection.Text=Sheet1.Range(C&b)'替换.Selection.MoveRightUnit:=1,Count:=1'右移LoopEndIfNext.ActiveDocument.SaveAsp&wjj&\&f'另存为。。。.Documents.CloseFalsef=DirLoop.QuitEndWithApplication.ScreenUpdating=TrueIfSheet1.Range(F1)=修改本级文档ThenMsgBox(完成!!!共修改&i&个文档。联系QQ：136941975提示)'直接退出ExitSubEndIfms=MsgBox(共修改&i&个文档。联系QQ：136941975&vbCrLf&是否保存数据？&vbCrLf&点击“是”保存数据；点击“否”取消保存。,vbYesNo+vbInformation,提示)Ifms=vbNoThenActiveWorkbook.SaveActiveWorkbook.SaveAsFilename:=_p&wjj&\&001信息录入.xlsm,FileFormat:=_xlOpenXMLWorkbookMacroEnabled,CreateBackup:=FalseExitSubEndIf数据保存_AActiveWorkbook.SaveActiveWorkbook.SaveAsFilename:=_p&wjj&\&001信息录入.xlsm,FileFormat:=_xlOpenXMLWorkbookMacroEnabled,CreateBackup:=FalseEndSubSub数据提取_A()DimccsjAsRangeIfSheet1.Range(F2)=ThenCreateObject(Wscript.shell).popup请选择已存数据！,1,提示！,0+32ExitSubEndIfzhs=Sheet1.Range(c&Rows.Count).End(xlUp).RowIfzhs3Thenms=MsgBox(已有新录入数据，是否覆盖？&vbCrLf&vbCrLf&点击“是”覆盖；点击“否”取消。,vbYesNo+vbInformation,提示)Ifms=vbNoThenExitSubEndIfEndIfSetccsj=Sheet2.Range(A:A).Find(what:=Sheet1.Range(F2),SearchOrder:=xlByColumns)'查找f2所在位置sjh=ccsj.Row'行sjzl=Sheet2.Cells(sjh,256).End(xlToLeft).Column'总数量，列Forhz=1TosjzlSheet1.Range(C&hz+2)=Sheet2.Cells(sjh,hz)NextEndSubSub数据保存_A()Dimk,n,oAsLong,zhs,hzzhs=Sheet1.Range(c&Rows.Count).End(xlUp).RowSetRng=Sheet2.Range(A:A).Find(what:=Sheet1.Range(C3),SearchOrder:=xlByColumns)IfNotRngIsNothingThenms=MsgBox(该案号已经存，是否更新数据？&vbCrLf&vbCrLf&点击“是”更新数据；点击“否”取消保存。,vbYesNo+vbInformation,提示)Ifms=vbNoThenExitSubElsen=Rng.Row'确定已存数据行Forhz=3TozhsIfSheet1.Range(C&hz)ThenSheet2.Cells(n,hz-2)=Sheet1.Range(C&hz)EndIfNextWithSheet2.Cells'格式缩小字体填充.WrapText=False.ShrinkToFit=TrueEndWithCreateObject(Wscript.shell).popup数据更新成功！,1,提示！,0+32ExitSubEndIfEndIff1=Sheet2.Range(A&Rows.Count).End(xlUp).Row+1Forhz=3TozhsIfSheet1.Range(C&hz)ThenSheet2.Cells(f1,hz-2)=Sheet1.Range(C&hz)EndIfNextWithSheet2.Cells'格式缩小字体填充.WrapText=False.ShrinkToFit=TrueEndWithCreateObject(Wscript.shell).popup数据保存成功！,1,提示！,0+32EndSub