用vba实现多个word文档里的多个内容进行批量更改说明：本方法思路是借用excel的表格对多个内容进行界面管理，再用excel的vba调用word文件进行查找更改。
使用方法：将以下内容（不包括本句）复制进excel的宏模块，保存，然后excel界面设置如下：输入数据，运行宏就可以了。
（若需要现成的excel文件，请单独下载）注：版权所有严禁转载Sub 更新录入()Dim a, b, zhszhs = Sheet1.Range("c" & Rows.Count).End(xlUp).Rowp = ThisWorkbook.Path & "\"If Sheet1.Range("c5").Value = "" Thenwjj = "新文书"Elsewjj = Sheet1.Range("c5").ValueEnd IfIf zhs < 3 ThenCreateObject("Wscript.shell").popup "没有数据可以录入,请输入数据后再点击生成新文档！", 1, "提示！", 0 + 32Exit SubEnd IfIf Sheet1.Range("F1") <> "修改本级文档" ThenOn Error Resume NextSet ofso = CreateObject("Scripting.FileSystemObject") '生成文件夹ofso.CreateFolder (p & wjj)On Error GoTo 0 '替换本级或生成新的ElseIf MsgBox("是否替换本级文件夹内文档？", vbYesNo, "提示") = vbNo Then: Exit Sub Elsewjj = ""End IfApplication.ScreenUpdating = FalseWith CreateObject("Word.Application").Visible = Falsef = Dir(p & "*.doc")Do While f <> ""i = i + 1.Documents.Open p & fFor b = 3 To zhsIf Sheet1.Range("C" & b) <> "" Then '有数据才替换.Selection.HomeKey Unit:=6 ' 到文档开始地方Do While .Selection.Find.Execute(Sheet1.Range("B" & b)) '查找s.Selection.Font.Color = wdColorAutomatic '字体颜色.Selection.Text = Sheet1.Range("C" & b) '替换.Selection.MoveRight Unit:=1, Count:=1 '右移LoopEnd IfNext.ActiveDocument.SaveAs p & wjj & "\" & f '另存为。
.Documents.Close Falsef = DirLoop.QuitEnd WithApplication.ScreenUpdating = TrueIf Sheet1.Range("F1") = "修改本级文档" ThenMsgBox ("完成共修改" & i & "个文档。
联系QQ：136941975""提示") '直接退出Exit SubEnd Ifms = MsgBox("共修改" & i & "个文档。
联系QQ：136941975" & vbCrLf & "是否保存数据？" & vbCrLf & "点击“是”保存数据；点击“否”取消保存。
", vbYesNo + vbInformation, "提示")If ms = vbNo ThenActiveWorkbook.SaveActiveWorkbook.SaveAs Filename:= _p & wjj & "\" & "001信息录入.xlsm", FileFormat:= _xlOpenXMLWorkbookMacroEnabled, CreateBackup:=FalseExit SubEnd If数据保存_AActiveWorkbook.SaveActiveWorkbook.SaveAs Filename:= _p & wjj & "\" & "001信息录入.xlsm", FileFormat:= _xlOpenXMLWorkbookMacroEnabled, CreateBackup:=FalseEnd SubSub 数据提取_A()Dim ccsj As RangeIf Sheet1.Range("F2") = "" ThenCreateObject("Wscript.shell").popup "请选择已存数据！", 1, "提示！", 0 + 32Exit SubEnd Ifzhs = Sheet1.Range("c" & Rows.Count).End(xlUp).RowIf zhs > 3 Thenms = MsgBox("已有新录入数据，是否覆盖？" & vbCrLf & vbCrLf & "点击“是”覆盖；点击“否”取消。
", vbYesNo + vbInformation, "提示")If ms = vbNo ThenExit SubEnd IfEnd IfSet ccsj = Sheet2.Range("A:A").Find(what:=Sheet1.Range("F2"), SearchOrder:=xlByColumns) '查找f2所在位置sjh = ccsj.Row '行sjzl = Sheet2.Cells(sjh, 256).End(xlToLeft).Column '总数量，列For hz = 1 To sjzlSheet1.Range("C" & hz + 2) = Sheet2.Cells(sjh, hz)NextEnd SubSub 数据保存_A()Dim k, n, o As Long, zhs, hzzhs = Sheet1.Range("c" & Rows.Count).End(xlUp).RowSet Rng = Sheet2.Range("A:A").Find(what:=Sheet1.Range("C3"), SearchOrder:=xlByColumns)If Not Rng Is Nothing Thenms = MsgBox("该案号已经存，是否更新数据？" & vbCrLf & vbCrLf & "点击“是”更新数据；点击“否”取消保存。
", vbYesNo + vbInformation, "提示")If ms = vbNo ThenExit SubElsen = Rng.Row '确定已存数据行For hz = 3 To zhsIf Sheet1.Range("C" & hz) <> "" ThenSheet2.Cells(n, hz - 2) = Sheet1.Range("C" & hz)End IfNextWith Sheet2.Cells '格式缩小字体填充.WrapText = False.ShrinkToFit = TrueEnd WithCreateObject("Wscript.shell").popup "数据更新成功！", 1, "提示！", 0 + 32 Exit SubEnd IfEnd Iff1 = Sheet2.Range("A" & Rows.Count).End(xlUp).Row + 1For hz = 3 To zhsIf Sheet1.Range("C" & hz) <> "" ThenSheet2.Cells(f1, hz - 2) = Sheet1.Range("C" & hz)End IfNextWith Sheet2.Cells '格式缩小字体填充.WrapText = False.ShrinkToFit = TrueEnd WithCreateObject("Wscript.shell").popup "数据保存成功！", 1, "提示！", 0 + 32 End Sub。