Word 自动化：一对多邮件合并

Aria2026-01-22约 9 分钟

警告

本文最后更新于 2026-01-22，文中内容可能已过时。

在实际业务中，经常需要根据 Excel 中的多笔订单明细，按订单分别生成对应的 Word 文档。由于一份文档通常关联多行明细，Word 默认的邮件合并方式难以直接满足这一需求。

假设需要为每家公司生成一份 Word 文档，包含其全部产品明细及订单图片。下面从 Excel 数据准备与结构化处理入手，结合 Word 邮件合并的规则域与宏工具，实现这一对多邮件合并。¹

Excel 数据处理

数据准备

准备数据文件 采购单.xlsx（采购单），其内容示例如下：

如图所示，表中包含 A~E 公司的采购明细。假设图片存放在 D:\img 目录，以订单号命名（.png），在 D2 单元格输入以下公式并向下填充，即可生成图片路径：

Plaintext
1
="D:\\img\\"&A2&".png"

⚠️ 注意：路径分隔符必须使用 \\，否则 Word 邮件合并无法正确识别图片路径。

数值计算

为简化后续 Word 邮件合并操作，建议在 Excel 中预先完成数据计算与逻辑判断。开始前，按订单号对数据升序排序，确保同一订单的明细连续排列。

小计：小计 = 数量 × 单价。在 I2 单元格输入以下公式并向下填充：

Plaintext
1
=G2*H2

合计：同一订单下各产品小计的总和。在 J2 单元格输入以下公式并向下填充：

Plaintext
1
=SUMIF($A:$A,A2,$I:$I)

大写金额：将合计转换为中文大写。在 K2 单元格输入以下公式并向下填充：

Plaintext
1
=SUBSTITUTE(SUBSTITUTE(IF(J2<0,"负","")&TEXT(TRUNC(ABS(ROUND(J2,2))),"[DBNum2]")&"元"&IF(ISERR(FIND(".",ROUND(J2,2))),"",TEXT(RIGHT(TRUNC(ROUND(J2,2)*10)),"[DBNum2]"))&IF(ISERR(FIND(".0",TEXT(J2,"0.00"))),"角","")&IF(LEFT(RIGHT(ROUND(J2,2),3))=".",TEXT(RIGHT(ROUND(J2,2)),"[DBNum2]")&"分",IF(ROUND(J2,2)=0,"","整")),"零元零",""),"零元","零")

实际使用中，也可通过自定义函数或插件（如方方格子）简化处理大写金额。

逻辑判断

WPS 无需辅助列：设置保留两位小数后，点击 开始 > 数字格式 > 转换 > 数字转为文本型数字。

为实现分组控制与分页处理，增加辅助列：下一行是否同订单（L列）、单笔订单明细数（M 列）。

下一行是否同订单（L 列）：判断当前行与下一行是否属于同一订单，用于控制分组的结束位置及分页。在 L2 单元格输入以下公式并向下填充：

Plaintext
1
=IF(A3=A2,1,0)

返回 1：下一行与当前行同订单（当前行不是最后一条）。
返回 0：下一行订单号不同（当前行是该订单的最后一条）。

单笔订单明细数（M 列）：统计每笔订单包含的明细记录数量，用于分页或分组判断。在 M2 单元格输入以下公式并向下填充：

Plaintext
1
=COUNTIF($A:$A,A2)

数值转换

Word 邮件合并不会保留 Excel 的数值显示格式，易导致小数位异常，建议在 Excel 中将数值转换为文本。

需要转换的字段包括数量、单价、小计、合计，因此在表格最右侧新增 N~Q 列，在 N2 单元格输入以下公式并向右、向下填充：

Plaintext
1
=TEXT(ROUND(F2,2),"0.00")

ROUND(F2,2)：强制保留两位小数。
TEXT(...,"0.00")：转换为始终显示两位小数的文本。

填充后，相关字段即转换为文本格式，可直接用于邮件合并。

Word 邮件合并

选择数据源

新建 采购单.docx（采购单），其内容示例如下：

如图所示，模板中包含订单信息区、采购明细表、合计区域及图片展示区。之前已计算出 单笔订单明细数 最大值为 6，因此明细表要预留 6 行。

点击 邮件 > 开始邮件合并 > 普通 Word 文档，启用邮件合并功能；点击 选择收件人> 使用现有列表，选择 采购单.xlsx，建立数据连接。

插入合并域

如果使用 WPS，数量、单价、小计、合计直接插入相应字段即可。

点击 邮件 > 插入合并域，插入对应字段到相应位置，示例如下：

如图所示，订单号、采购方、联系人、合计金额等字段均为一对一关系，而 图片演示 需通过域插入：点击 插入 > 文档部件 > 域，选择 IncludePicture，先在域属性中输入占位值（如 1），确认插入后，将其替换为图片路径的合并域，即可自动加载图片。

插入的合并域通常显示为 «字段名»，可通过 Alt+F9 切换域代码。

编写域规则

💡 域代码的 { } 需按 Ctrl+F9 输入，或通过菜单栏插入域后按 Alt+F9 编辑。²

由于同一订单的明细数量不定，需要在一份 Word 文档中逐行输出多条记录。此前在 Excel 中已计算出用于控制明细表的循环输出的 下一行是否同订单 字段：=1 表示仍为同一订单，=0 表示订单已切换。

本例采用 SET、NEXTIF、IF 三个域组合控制：

SET：将当前行的判断结果存入变量。
NEXTIF：满足条件时读取下一条记录。
IF：控制当前行是否输出数据。

将光标定位到明细表 产品名称 的第二行单元格，点击 邮件 > 规则，依次插入：

顺序	规则类型	设置内容
1	设置书签 (SET)	书签名称：`A` 值： `{ MERGEFIELD 下一行是否同订单 }`
2	下一记录条件 (NEXTIF)	域名：下一行是否同订单比较条件：等于比较对象：`1`
3	如果…那么…否则 (IF)	域名：下一行是否同订单比较条件：等于则插入此文字：`{ MERGEFIELD 产品名称 }`

插入时可先用占位值（如 1）完成向导，再按 Alt+F9 编辑，最终代码结构如下：

Plaintext
1
SET A "{ MERGEFIELD 下一行是否同订单 }" }{ NEXTIF { MERGEFIELD 下一行是否同订单 } = 1 }{ IF { MERGEFIELD 下一行是否同订单 } = 1 "{ MERGEFIELD 产品名称 }" "" }

为避免数据源错位，后续判断统一使用变量 A，将 NEXTIF 和 IF 中的域替换为 A：

Plaintext
1
SET A "{ MERGEFIELD 下一行是否同订单 }" }{ NEXTIF A = 1 }{ IF A = 1 "{ MERGEFIELD 产品名称 }" "" }

接着将 { IF A = 1 "{ MERGEFIELD 产品名称 }" "" } 复制到规格、数量、单价、小计列，并替换合并域：

Plaintext
1
2
3
4
{ IF A = 1 "{ MERGEFIELD 规格 }" "" }
{ IF A = 1 "{ MERGEFIELD 数量1 }" "" }
{ IF A = 1 "{ MERGEFIELD 单价1 }" "" }
{ IF A = 1 "{ MERGEFIELD 小计1 }" "" }

最后，选中第二行的产品名称、规格、数量、单价、小计，复制到第 3~6 行，作为明细表的预留行。

预览与合并

预览状态下图片字段仅显示第一条记录，待合并完成后按 F9 刷新即可。

插入域后，按 Alt+F9 隐藏域代码，点击 预览结果 查看每份文档的合并效果。确认无误后，点击 完成与合并 > 编辑单个文档，生成包含所有订单的合并文档。

合并后，全选文档（Ctrl+A ）并按 F9 刷新域，使图片更新为对应订单的正确内容。

自动拆分文档

开启开发工具：点击 文件 > 选项 > 自定义功能区，勾选 开发工具。

Word 默认生成的合并文档包含所有订单，如需将每份采购单保存为独立文件，可通过宏自动拆分。

在最终合并文档中，点击 开发工具 > Visual Basic > 插入 > 模块，输入以下宏代码：

VBA按节拆分文档_可选格式.bas
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
Sub 按节拆分文档_可选格式()
    ' 功能：按节拆分文档，可选择导出为DOCX或PDF格式，并自动归类保存。
    ' 特点：提供格式选择、PDF高质量导出、自动归类、格式保真。

    Dim originalDoc As Document, newDoc As Document
    Dim originalSection As Section
    Dim i As Long, response As VbMsgBoxResult
    Dim saveFolderPath As String, formatSubFolder As String, fso As Object
    Dim originalRangeToCopy As Range
    Dim exportFormat As String, formatDescription As String

    ' 1. 让用户选择导出格式
    response = MsgBox("请选择要导出的文件格式：" & vbCrLf & vbCrLf & _
                      "按 [是] 导出为 PDF 格式" & vbCrLf & _
                      "按 [否] 导出为 DOCX 格式" & vbCrLf & _
                      "按 [取消] 中止操作", _
                      vbYesNoCancel + vbQuestion, "选择导出格式")

    ' 根据用户选择确定格式
    Select Case response
        Case vbYes
            exportFormat = "PDF"
            formatDescription = "PDF文档"
            formatSubFolder = "PDF文件"
        Case vbNo
            exportFormat = "DOCX"
            formatDescription = "Word文档"
            formatSubFolder = "Word文件"
        Case vbCancel
            MsgBox "操作已取消。", vbInformation
            Exit Sub
    End Select

    ' 确认操作
    If MsgBox("即将按节拆分文档，并导出为 " & formatDescription & "。" & vbCrLf & _
              "是否继续？", vbYesNo + vbQuestion, "确认操作") <> vbYes Then
        Exit Sub
    End If

    ' 2. 初始化设置
    Set originalDoc = ActiveDocument
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error GoTo ErrorHandler

    ' 3. 创建文件夹结构
    Set fso = CreateObject("Scripting.FileSystemObject")
    saveFolderPath = originalDoc.Path & "\拆分结果\" & formatSubFolder & "\"

    ' 如果文件夹已存在，清空里面的文件
    If fso.FolderExists(saveFolderPath) Then
        On Error Resume Next
        fso.DeleteFile saveFolderPath & "*.*"
        On Error GoTo ErrorHandler
    Else
        ' 创建文件夹（包括父文件夹）
        If Not fso.FolderExists(originalDoc.Path & "\拆分结果\") Then
            fso.CreateFolder (originalDoc.Path & "\拆分结果\")
        End If
        fso.CreateFolder (saveFolderPath)
    End If

    ' 4. 遍历每一节进行拆分
    For i = 1 To originalDoc.Sections.Count
        Set originalSection = originalDoc.Sections(i)
        Set originalRangeToCopy = originalSection.Range.Duplicate

        ' 调整复制范围，排除节末尾的分节符
        If i < originalDoc.Sections.Count Then
            originalRangeToCopy.End = originalSection.Range.End - 1
        End If

        ' 跳过空内容节
        If Len(Trim(originalRangeToCopy.Text)) <= 1 Then
            GoTo ContinueNext
        End If

        ' 创建新文档并粘贴内容
        Set newDoc = Documents.Add(Visible:=False)
        originalRangeToCopy.Copy
        newDoc.Content.PasteAndFormat (wdFormatOriginalFormatting)

        ' 复制页面设置
        With newDoc.PageSetup
            .Orientation = originalSection.PageSetup.Orientation
            .TopMargin = originalSection.PageSetup.TopMargin
            .BottomMargin = originalSection.PageSetup.BottomMargin
            .LeftMargin = originalSection.PageSetup.LeftMargin
            .RightMargin = originalSection.PageSetup.RightMargin
            .PageWidth = originalSection.PageSetup.PageWidth
            .PageHeight = originalSection.PageSetup.PageHeight
        End With

        ' 5. 根据选择的格式保存文件
        Dim fileName As String
        fileName = saveFolderPath & "文档_" & Format(i, "000")

        If exportFormat = "PDF" Then
            ' 导出为PDF（高质量设置）
            newDoc.ExportAsFixedFormat _
                OutputFileName:=fileName & ".pdf", _
                ExportFormat:=wdExportFormatPDF, _
                OpenAfterExport:=False, _
                OptimizeFor:=wdExportOptimizeForPrint, _
                Range:=wdExportAllDocument, _
                Item:=wdExportDocumentContent, _
                IncludeDocProps:=True, _
                KeepIRM:=True, _
                CreateBookmarks:=wdExportCreateNoBookmarks, _
                DocStructureTags:=True, _
                BitmapMissingFonts:=True, _
                UseISO19005_1:=True  ' PDF/A 兼容性，确保长期可读
        Else
            ' 保存为DOCX
            newDoc.SaveAs2 FileName:=fileName & ".docx"
        End If

        ' 关闭文档，不保存中间文档
        newDoc.Close SaveChanges:=False
        Set newDoc = Nothing

ContinueNext:
        Set originalRangeToCopy = Nothing
    Next i

    ' 6. 完成操作
    originalDoc.Activate
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    ' 显示完成信息，并询问是否打开文件夹
    Dim openFolder As VbMsgBoxResult
    openFolder = MsgBox("拆分完成！" & vbCrLf & _
                        "共处理 " & originalDoc.Sections.Count & " 个节。" & vbCrLf & _
                        "文件已保存至：" & saveFolderPath & vbCrLf & vbCrLf & _
                        "是否打开保存文件夹？", _
                        vbYesNo + vbInformation, "操作完成")

    If openFolder = vbYes Then
        ' 使用Shell打开文件夹
        Shell "explorer.exe """ & saveFolderPath & """", vbNormalFocus
    End If

    Set fso = Nothing
    Exit Sub

ErrorHandler:
    If Not newDoc Is Nothing Then
        newDoc.Close SaveChanges:=False
        Set newDoc = Nothing
    End If
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    MsgBox "处理第 " & i & " 节时出错：" & vbCrLf & _
           "错误号：" & Err.Number & vbCrLf & _
           "错误描述：" & Err.Description, vbCritical

    Set fso = Nothing
End Sub

完成后关闭编辑器，点击宏并运行，根据提示选择导出格式（ .pdf 或 .docx）。

运行后，原文档同级目录生成：

Plaintext
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
原文档所在文件夹/
├── 拆分结果/
│   ├── PDF文件/      （导出为 PDF）
│   │   ├── 文档_001.pdf
│   │   ├── 文档_002.pdf
│   │   └── ...
│   └── Word文件/     （导出为 DOCX）
│       ├── 文档_001.docx
│       ├── 文档_002.docx
│       └── ...