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

用vba实现多个word文档里的多个内容进行批量更改

说明：本方法思路是借用excel的表格对多个内容进行界面管理，再用excel的vba调用word文件进行查找更改。

使用方法：

将以下内容（不包括本句）复制进excel的宏模块，保存，然后excel界面设置如下：

输入数据，运行宏就可以了。（若需要现成的excel文件，请单独下载）

注：版权所有严禁转载

Sub 更新录入()

Dim a, b, zhs

zhs = Sheet1.Range("c" & Rows.Count).End(xlUp).Row

p = ThisWorkbook.Path & "\"

If Sheet1.Range("c5").Value = "" Then

wjj = "新文书"

Else

wjj = Sheet1.Range("c5").Value

End If

If zhs < 3 Then

CreateObject("Wscript.shell").popup "没有数据可以录入,请输入数据后再点击生成新文档！", 1, "提示！", 0 + 32

Exit Sub

End If

If Sheet1.Range("F1") <> "修改本级文档" Then

On Error Resume Next

Set ofso = CreateObject("Scripting.FileSystemObject") '生成文件夹

ofso.CreateFolder (p & wjj)

On Error GoTo 0 '替换本级或生成新的

ElseIf MsgBox("是否替换本级文件夹内文档？", vbYesNo, "提示") = vbNo Then: Exit Sub Else

wjj = ""

End If

Application.ScreenUpdating = False

With CreateObject("Word.Application")

.Visible = False

f = Dir(p & "*.doc")

Do While f <> ""

i = i + 1

.Documents.Open p & f

For b = 3 To zhs

If 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 '右移

Loop

End If

Next

.ActiveDocument.SaveAs p & wjj & "\" & f '另存为。。。

.Documents.Close False

f = Dir

Loop

.Quit

End With

Application.ScreenUpdating = True

If Sheet1.Range("F1") = "修改本级文档" Then

MsgBox ("完成!!!共修改" & i & "个文档。联系QQ：136941975""提示") '直接退出

Exit Sub

End If

ms = MsgBox("共修改" & i & "个文档。联系QQ：136941975" & vbCrLf & "是否保存数据？" & vbCrLf & "点击“是”保存数据；点击“否”取消保存。", vbYesNo + vbInformation, "提示")

If ms = vbNo Then

ActiveWorkbook.Save

ActiveWorkbook.SaveAs Filename:= _

p & wjj & "\" & "001信息录入.xlsm", FileFormat:= _

xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

Exit Sub

End If

数据保存_A

ActiveWorkbook.Save

ActiveWorkbook.SaveAs Filename:= _

p & wjj & "\" & "001信息录入.xlsm", FileFormat:= _

xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

End Sub

Sub 数据提取_A()

Dim ccsj As Range

If Sheet1.Range("F2") = "" Then

CreateObject("Wscript.shell").popup "请选择已存数据！", 1, "提示！", 0 + 32

Exit Sub

End If

zhs = Sheet1.Range("c" & Rows.Count).End(xlUp).Row

If zhs > 3 Then

ms = MsgBox("已有新录入数据，是否覆盖？" & vbCrLf & vbCrLf & "点击“是”覆盖；点击“否”取消。", vbYesNo + vbInformation, "提示")

If ms = vbNo Then

Exit Sub

End If

End If

Set 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 sjzl

Sheet1.Range("C" & hz + 2) = Sheet2.Cells(sjh, hz)

Next

End Sub

Sub 数据保存_A()

Dim k, n, o As Long, zhs, hz

zhs = Sheet1.Range("c" & Rows.Count).End(xlUp).Row

Set Rng = Sheet2.Range("A:A").Find(what:=Sheet1.Range("C3"), SearchOrder:=xlByColumns)

If Not Rng Is Nothing Then

ms = MsgBox("该案号已经存，是否更新数据？" & vbCrLf & vbCrLf & "点击“是”更新数据；点击“否”取消保存。", vbYesNo + vbInformation, "提示")

If ms = vbNo Then

Exit Sub

Else

n = Rng.Row '确定已存数据行

For hz = 3 To zhs

If Sheet1.Range("C" & hz) <> "" Then

Sheet2.Cells(n, hz - 2) = Sheet1.Range("C" & hz)

End If

Next

With Sheet2.Cells '格式缩小字体填充

.WrapText = False

.ShrinkToFit = True

End With

CreateObject("Wscript.shell").popup "数据更新成功！", 1, "提示！", 0 + 32 Exit Sub

End If

End If

f1 = Sheet2.Range("A" & Rows.Count).End(xlUp).Row + 1

For hz = 3 To zhs

If Sheet1.Range("C" & hz) <> "" Then

Sheet2.Cells(f1, hz - 2) = Sheet1.Range("C" & hz)

End If

Next

With Sheet2.Cells '格式缩小字体填充

.WrapText = False

.ShrinkToFit = True

End With

CreateObject("Wscript.shell").popup "数据保存成功！", 1, "提示！", 0 + 32 End Sub

本文来源：https://www.bwwdw.com/article/9oul.html