Word·VBA实现邮件合并

之前写过的一篇使用《python实现word邮件合并》，本文为vba实现方法

制作邮件合并模板

域名可以使用中文，最终完成的word模板，wps操作步骤类似

VBA邮件合并_按域名写入

在Excel启用宏的工作表运行以下代码，读取当前工作表数据，对模板word文档，按工作表表头名称对同一域名写入值，生成新文档

Sub word邮件合并_按域名写入()
    '读取当前工作表数据，按arr二维数组第1行表头名称，对word文档中同一域名写入值，生成新文档
    Dim fso As Object, wd As Object, docx$, save_path$, arr, i&, j&, k, v, fs, f
'--------------------参数填写：docx、arr、save_path
    docx = "E:\测试\docx\证明-模板.docx"  '模板文件路径
    arr = ActiveSheet.[a1].CurrentRegion.Value     '合并数据，当前工作表
    save_path = ActiveWorkbook.path & "\结果\"     '文件保存路径
    Set fso = CreateObject("Scripting.FileSystemObject"): tm = Timer
    If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path)  '创建文件夹
    Set wd = CreateObject("word.application") ': wd.Visible = True  '默认不可见
    Set tmpl = wd.Documents.Open(docx)
    For i = 2 To UBound(arr)
        With tmpl
            For j = 1 To UBound(arr, 2)
                k = arr(1, j): v = arr(i, j)  'k表头/域名，v值
                Set fs = .Content.Fields  '域集合
                For Each f In fs
                    'Field.Code域代码，Field.Result域结果
                    If InStr(f.Code.text, k) Then f.result.text = v
                Next
            Next
            .SaveAs save_path & arr(i, 2) & ".docx"
        End With
    Next
    tmpl.Close: wd.Quit  '关闭文件，退出程序
    Debug.Print "word邮件合并完成，用时：" & Format(Timer - tm, "0.00")
End Sub

• 参考资料：
  《Range 对象 (Word)》、《Field 对象 (Word)》

举例

Excel工作表表头与Word文档域名相同

• 合并结果，20个文件生成用时4.62秒
  
  

VBA邮件合并_按顺序写入

在Excel启用宏的工作表运行以下代码，读取当前工作表数据，对模板word文档，按文档中域的顺序写入值，生成新文档

Sub word邮件合并_按顺序写入()
    '读取当前工作表数据，按顺序对word文档中域写入值，生成新文档
    Dim fso As Object, wd As Object, docx$, save_path$, arr, i&, j&, fs, f
'--------------------参数填写：docx、arr、save_path
    docx = "E:\测试\docx\证明\证明-模板2.docx"  '模板文件路径
    arr = ActiveSheet.[a1].CurrentRegion.Value     '合并数据，当前工作表
    save_path = ActiveWorkbook.path & "\结果2\"     '文件保存路径
    Set fso = CreateObject("Scripting.FileSystemObject"): tm = Timer
    If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path)  '创建文件夹
    Set wd = CreateObject("word.application") ': wd.Visible = True  '默认不可见
    Set tmpl = wd.Documents.Open(docx)
    For i = 2 To UBound(arr)
        With tmpl
            j = 1: Set fs = .Content.Fields  '域集合
            If fs.Count >= 1 Then
                Set f = fs(1)
                While Not f Is Nothing
                    j = j + 1: f.result.text = arr(i, j)
                    Set f = f.Next  '下一个
                Wend
            End If
            .SaveAs save_path & arr(i, 2) & ".docx"
        End With
    Next
    tmpl.Close: wd.Quit  '关闭文件，退出程序
    Debug.Print "word邮件合并完成，用时：" & Format(Timer - tm, "0.00")
End Sub

• 参考资料：
  《Field.Next 属性 (Word)》

举例

在原本的模板上添加了5个域，也可使用Next域，不过Next域在模板中不可见，故推荐使用原来的MergeField域

• 合并结果，20个文件生成用时4.58秒