用vba实现多个word文档里的多个内容进行批量更改多个word信息批量替换■IM目标T——H * 戢入说明：本方法思路是借用 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").ValueEndIfIfzhs<3ThenCreateObject("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")DoWhilef<>""i=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&"个文档联系：136941975""提示")'直接退出ExitSubEndIfms=MsgBox("共修改"&i&"个文档联系：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).RowIfzhs>3Thenms=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。