word邮件合并多个独立文档（王柏川Get这招后轻松搞定小美）

小美作为一大型公司的HR，难免经常需要发送通知。这次小美的领导安迪说，需要小美给公司2000 人员工发送一封邮件，可是每个员工mail的附件都不一样。这可愁坏了HR小美。

怎么办？总不可能一封一封的发。于是，小美给男友王柏川打电话，讲述了经过。说，“你一定要帮我解决，否则晚上你回去跪电子秤，让你跪五斤，你不许跪出五斤一两”——小编一脸懵逼

王柏川立马想到了他的好友IT工程师雷哥，雷哥经过简单的思考后，立马给出了解决方案。方法如下：

附件为txt文件，路径为C:\Users\lei.pei\Desktop\word

附件截图

整理用户清单：用户的邮件地址和对应的附件地址（本文中整理后的文档是name.docx）

用户和对应的附件清单

Step1：使用现有列表——选择 name文件

Step2: 【插入合并域】，完成如图设置

Step3： 在模板末尾插入分隔符（否则只能发送一封邮件）

【布局】-分页符【下一节】

Step4：点击【完成并合并】-【编辑单个文档】

Step5：打开的文档中，双击【thisdocument】-【工具】-【引用】-找到【Microsoft Outlook 16.0 object library】

注：不同的office版本，outlook 后的数字不同。本文是office 2016，所以显示的是16.0

Step6：输入代码

注：这段代码非原创，来自网络。局部地方有纠正

Sub eMailMergeWithAttachments()

Dim docSource As Document, docMaillist As Document, docTempDoc As Document

Dim rngDatarange As Range

Dim i As Long, j As Long

Dim lSectionsCount As Long

Dim bStarted As Boolean

Dim oOutlookApp As Outlook.Application

Dim oItem As Outlook.MailItem

Dim oAccount As Outlook.Account

Dim sMySubject As String, sMessage As String, sTitle As String

'将当前文档设置为源文档（主文档）

Set docSource = ActiveDocument

'检查Outlook是不是打开了。如果未打开的话，就打开新的Outlook

On Error Resume Next

Set oOutlookApp = GetObject(, "Outlook.Application")

If Err <> 0 Then

Set oOutlookApp = CreateObject("Outlook.Application")

bStarted = True

End If

'打开保存有客人的邮件地址和需要发送的附件的路径的word文档。

With Dialogs(wdDialogFileOpen)

.Show

End With

'将该文档设置为客户邮件（附件）列表文档

Set docMaillist = ActiveDocument

'设置发送邮件的账户（账户必须已经在Outlook中设置好了）

'注意：如果你的Outlook版本低于2007，使用设置发送邮件的账户可能会导致错误，

'建议将下面的Set oAccount = oOutlookApp.Session.Accounts.Item("someone@examplemail.com")语句删除

Set oAccount = oOutlookApp.Session.Accounts.Item("someone@examplemail.com")

'显示一个输入框，询问并让用户输入邮件主题

sMessage = "请为要发送的邮件输入邮件主题。"

sTitle = "输入邮件主题"

sMySubject = InputBox(sMessage, sTitle)

'循环查找源文档中所有的节（每一节为一封邮件内容），以及循环查找邮件列表文档中所有的客户信息，

'以便用于插入到生成的邮件中

lSectionsCount = docSource.Sections.Count

'当源文档中的节数仅有1时，lSectionsCount=0，将导致程序无法正常运行。

'为了保证当源文档只有1节时程序能正常运行，必须使lSectionsCount至少等于1

If lSectionsCount = 0 Then lSectionsCount = 1

For j = 1 To lSectionsCount

Set oItem = oOutlookApp.CreateItem(olMailItem)

With oItem

'注意：如果你的Outlook版本低于2007，使用设置发送邮件的账户可能会导致错误，

'建议将下面的.SendUsingAccount = oAccount语句删除

.SendUsingAccount = oAccount

.Subject = sMySubject

.Body = docSource.Sections(j - 1).Range.Text

Set rngDatarange = docMaillist.Tables(1).Cell(j, 1).Range

rngDatarange.End = rngDatarange.End - 1

.To = rngDatarange

For i = 2 To docMaillist.Tables(1).Columns.Count

Set rngDatarange = docMaillist.Tables(1).Cell(j, i).Range

rngDatarange.End = rngDatarange.End - 1

.Attachments.Add Trim(rngDatarange.Text), olByValue, 1

Next i

.Send

End With

Set oItem = Nothing

Next j

docMaillist.Close wdDoNotSaveChanges

'如果Outlook是由该宏打开的，则关闭Outlook

If bStarted Then

oOutlookApp.Quit

End If

MsgBox "共发送了 " & lSectionsCount & " 封邮件。"

'清空Outlook实例

Set oOutlookApp = Nothing

End Sub

Step7：运行代码

运行代码的过程中，第一次弹出对话框，需要选择name文件，第二次需要输入主题

---

注意事项

1. 正文的模板内容可以根据需求自定义格式

2. 分页符是在邮件合并之前要插入

3. 邮件合并完成后，注意不能有空白页。否则会出现一个用户收到多封空白邮件的情况

4. 如果插入分页符后，发现有空白页。可以试试Ctrl Enter

---

雷哥帮王柏川搞定了Excel和小美，他们不胜感激。据说周末要请我吃十三香的小龙虾

预知后续职场故事，请听雷哥下次精彩分享

,