wordvba

(完整版)用VBA实现

批量修改多个Word文

档内容

-CAL-FENGHAI-(2020YEAR-YICAI)_JINGBIAN

2

用vba实现多个word文档里的多个内容进

行批量更改

说明：本方法思路是借用excel的表格对多个内容进行界面管理，再用excel的

vba调用word文件进行查找更改。

使用方法：

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

如下：

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

注：版权所有严禁转载

Sub更新录入()

Dima,b,zhs

zhs=("c"&).End(xlUp).Row

p=&""

("c5").Value=""Then

wjj="新文书"

Else

wjj=("c5").Value

EndIf

Ifzhs<3Then

3

CreateObject("").popup"没有数据可以录入,请输入数据后再点击

生成新文档！",1,"提示！",0+32

ExitSub

EndIf

("F1")<>"修改本级文档"Then

OnErrorResumeNext

Setofso=CreateObject("stemObject")'生成文件夹

Folder(p&wjj)

OnErrorGoTo0'替换本级或生成新的

ElseIfMsgBox("是否替换本级文件夹内文档"

,vbYesNo,"提示")=vbNoThen:ExitSub

Else

wjj=""

EndIf

Updating=False

WithCreateObject("ation")

.Visible=False

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

DoWhilef<>""

i=i+1

.&f

Forb=3Tozhs

("C"&b)<>""Then'有数据才替换

.yUnit:=6'到文档开始地方

e(("B"&b))'查找s

.=wdColorAutomatic'字体颜色

.=("C"&b)'替换

.ghtUnit:=1,Count:=1'右移

Loop

EndIf

Next

4

.p&wjj&""&f'另存为。。。

.alse

f=Dir

Loop

.Quit

EndWith

Updating=True

("F1")="修改本级文档"Then

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

退出

ExitSub

EndIf

ms=MsgBox("共修改"&i&"个文档。联系QQ：136941975"&vbCrLf&"

是否保存数据"

&vbCrLf&"点击“是”保存数据；点击“否”取消保存。",vbYesNo+

vbInformation,"提示")

Ifms=vbNoThen

Filename:=_

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

xlOpenXMLWorkbookMacroEnabled,CreateBackup:=False

ExitSub

EndIf

数据保存_A

Filename:=_

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

xlOpenXMLWorkbookMacroEnabled,CreateBackup:=False

EndSub

Sub数据提取_A()

DimccsjAsRange

5

("F2")=""Then

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

ExitSub

EndIf

zhs=("c"&).End(xlUp).Row

Ifzhs>3Then

ms=MsgBox("已有新录入数据，是否覆盖"

&vbCrLf&vbCrLf&"点击“是”覆盖；点击“否”取消。",vbYesNo+

vbInformation,"提示")

Ifms=vbNoThen

ExitSub

EndIf

EndIf

Setccsj=("A:A").Find(what:=("F2"),

SearchOrder:=xlByColumns)'查找f2所在位置

sjh='行

sjzl=(sjh,256).End(xlToLeft).Column'总数量，列

Forhz=1Tosjzl

("C"&hz+2)=(sjh,hz)

Next

EndSub

Sub数据保存_A()

Dimk,n,oAsLong,zhs,hz

zhs=("c"&).End(xlUp).Row

SetRng=("A:A").Find(what:=("C3"),

SearchOrder:=xlByColumns)

IfNotRngIsNothingThen

ms=MsgBox("该案号已经存，是否更新数据"

&vbCrLf&vbCrLf&"点击“是”更新数据；点击“否”取消保存。",vbYesNo+

vbInformation,"提示")

Ifms=vbNoThen

ExitSub

6

Else

n='确定已存数据行

Forhz=3Tozhs

("C"&hz)<>""Then

(n,hz-2)=("C"&hz)

EndIf

Next

'格式缩小字体填充

.WrapText=False

.ShrinkToFit=True

EndWith

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

ExitSub

EndIf

EndIf

f1=("A"&).End(xlUp).Row+1

Forhz=3Tozhs

("C"&hz)<>""Then

(f1,hz-2)=("C"&hz)

EndIf

Next

'格式缩小字体填充

.WrapText=False

.ShrinkToFit=True

EndWith

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

EndSub