目录
- 1,复制法,不保留原文档格式
- 2,复制法,保留原文档格式
- 3,插入法,保留原文档格式
之前的文章《Word·VBA实现邮件合并》虽然可以生成邮件合并文档结果,但是不能像《python实现word邮件合并》一样,最终所有结果合并为1个文档,那么只能用vba实现文档合并功能
- 以下代码在
Word启用宏的文档
中运行
1,复制法,不保留原文档格式
Range.InsertAfter 方法
只能插入文本,因此合并结果不保留原文档格式
Sub 合并文档_复制法()
'合并文件夹中所有doc*文档,并保存文档至该文件夹;但不保留原文档格式
Dim file_path$, file_name$, docx As Document, f As Document
'--------------------参数填写:
file_path = "E:\测试\docx\结果\" '文件夹
file_name = Dir(file_path & "*.doc*"): tm = Timer
Set docx = Documents.Add '新建文档,合并文档
Application.ScreenUpdating = False '关闭屏幕更新,加快程序运行
Do While file_name <> ""
Set f = Documents.Open(file_path & file_name)
docx.Content.InsertAfter f.Content '将文档内容复制到合并文档末尾
f.Close (False)
file_name = Dir '下一个文件名
Loop
docx.SaveAs FileName:=file_path & "合并文档.docx" '保存
docx.Close
Application.ScreenUpdating = True
Debug.Print "文件夹文档合并完成,用时:" & Format(Timer - tm, "0.00") '耗时
End Sub
- 合并结果
2,复制法,保留原文档格式
rng.Paste
偶尔运行报错,原因未知
Sub 合并文档_复制法2()
'合并文件夹中所有doc*文档,并保存文档至该文件夹;保留原文档格式
Dim file_path$, file_name$, docx As Document, f As Document, rng As Range
'--------------------参数填写:
file_path = "E:\测试\docx\结果\" '文件夹
file_name = Dir(file_path & "*.doc*"): tm = Timer
Set docx = Documents.Add '新建文档,合并文档
Application.ScreenUpdating = False '关闭屏幕更新,加快程序运行
Do While file_name <> ""
Set f = Documents.Open(file_path & file_name)
Set rng = f.Content: rng.Copy
Set rng = docx.Content
rng.Collapse Direction:=wdCollapseEnd '结束位置
rng.Paste: rng.InsertAfter Chr(12) '粘贴,并插入换页符
f.Close (False)
file_name = Dir '下一个文件名
Loop
docx.SaveAs FileName:=file_path & "合并文档.docx" '保存
docx.Close
Application.ScreenUpdating = True
Debug.Print "文件夹文档合并完成,用时:" & Format(Timer - tm, "0.00") '耗时
End Sub
- 合并结果
3,插入法,保留原文档格式
Selection.InsertFile 方法
插入指定文件
Sub 合并文档_插入法()
'合并文件夹中所有doc*文档,并保存文档至该文件夹;保留原文档格式
Dim file_path$, file_name$, docx As Document
'--------------------参数填写:
file_path = "E:\测试\docx\结果\" '文件夹
file_name = Dir(file_path & "*.doc*"): tm = Timer
Set docx = Documents.Add '新建文档,合并文档
Application.ScreenUpdating = False '关闭屏幕更新,加快程序运行
Do While file_name <> ""
Selection.InsertFile FileName:=file_path & file_name, Link:=False '所有文档
Selection.InsertBreak Type:=wdPageBreak '插入换页符
file_name = Dir '下一个文件名
Loop
docx.SaveAs FileName:=file_path & "合并文档.docx" '保存
docx.Close
Application.ScreenUpdating = True
Debug.Print "文件夹文档合并完成,用时:" & Format(Timer - tm, "0.00") '耗时
End Sub
- 合并结果:与方法2一致
- 3种方法对比
文档合并 | 方法1 | 方法2 | 方法3 |
---|---|---|---|
耗时秒数 | 4.41 | 5.48 | 0.61 |
- 方法3不但生成结果与方法2一致,而且代码运行速度快数倍