Word·VBA文档合并

目录

• • 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一致，而且代码运行速度快数倍