邮件合并之EXCEL与WORD联动

libaoshui · 发表于 2019-5-19 21:55

问题描述：邮件合并问题，EXCEL数据按WORD模板，群发给每个人。其中，符合条件的可能有几项记录，需要合并在一起（不要一个个发）。内容行数不固定问题，已在解决，见链接：Excel群发邮件内容行数不固定如何解决，http://club.excelhome.net/thread-1418960-1-1.html，(出处: ExcelHome技术论坛)现在需要邮件群发，如何实现呢？

问题1：将WORD输出模板放置在EXCEL里（调整下格式，可能不太美观），邮件群发功能如何实现？
写了一段代码，有问题执行不了。请帮忙看下。

Option Explicit
Sub SendMailEnvelope_3() '引用Outlook对象使用CreateItem属性实现邮件群发
Dim d As Object, outApp As Object, arr As Variant, brr As Variant, kr As Variant, i%, l%, j%, k%, x%
Dim tmp$, tmpstr$, r As Variant
Set d = CreateObject("scripting.dictionary") 'set字典
Set outApp = CreateObject("outlook.application") 'set outlook
arr = Sheets("工资表").UsedRange '总表的数据区域
For i = 2 To UBound(arr) '遍历数组arr
If Not d.exists(arr(i, 1)) Then
d(arr(i, 1)) = i '字典中不存在关键词则将行号装入字典
Else
d(arr(i, 1)) = d(arr(i, 1)) & "," & i '如果存在则合并行号，以逗号间隔
End If
Next
kr = d.keys '字典的key集
Application.ScreenUpdating = False '关闭屏幕刷新
For i = 0 To UBound(kr) '遍历字典key值
r = Split(d(kr(i)), ",") '取出item里储存的行号
ReDim brr(1 To UBound(r) + 1, 1 To 8)
For x = 0 To UBound(r)
k = k + 1
l = l + 1
For j = 2 To UBound(arr, 2) '读取遍历列
brr(k, l) = arr(r(x), j)
Next j
Next x
Sheets("模板").Activate
[a2] = arr(r(x - 1), 2)
[b6] = brr
[a1].CurrentRegion.Select
With outApp.createitem(olmailitem) '如反馈olMailItem未找到工程或库，需在工具→引用→"Microsoft Outlook"
.To = kr(i) '------------收件人
.Subject = "测试邮件" '------------主题
.Send '------------发送邮件
End With
Next i
Application.ScreenUpdating = True '恢复屏幕更新
Set d = Nothing '释放字典
Set outApp = Nothing
MsgBox "共发送" & i & "封邮件！"
End Sub

复制代码

方法2：如果直接调用WORD模板，代码该如何调试？

libaoshui · 发表于 2019-5-20 21:35

咋没人看到呢？自己顶一个。

闻启学 · 发表于 2019-5-20 21:50

libaoshui 发表于 2019-5-20 21:35
咋没人看到呢？自己顶一个。

有个疑问工资条一般都是一对一，除非你需求不是工资条

跟我来！一步一步教你批量发送邮件
http://club.excelhome.net/thread-1158003-1-1.html
(出处: ExcelHome技术论坛)

这个帖子 101 楼是不是你需要结果

libaoshui · 发表于 2019-5-20 22:29

Option Explicit
Sub SendMailEnvelope_3() '引用Outlook对象使用CreateItem属性实现邮件群发
Dim d As Object, outApp As Object, arr As Variant, brr As Variant, kr As Variant, i%, l%, j%, k%, x%
Dim tmp$, tmpstr$, r As Variant
Set d = CreateObject("scripting.dictionary") 'set字典
Set outApp = CreateObject("outlook.application") 'set outlook
arr = Sheets("工资表").UsedRange '总表的数据区域
For i = 2 To UBound(arr) '遍历数组arr
If Not d.exists(arr(i, 1)) Then
d(arr(i, 1)) = i '字典中不存在关键词则将行号装入字典
Else
d(arr(i, 1)) = d(arr(i, 1)) & "," & i '如果存在则合并行号，以逗号间隔
End If
Next
kr = d.keys '字典的key集
Application.ScreenUpdating = False '关闭屏幕刷新
For i = 0 To UBound(kr) '遍历字典key值
r = Split(d(kr(i)), ",") '取出item里储存的行号
ReDim brr(1 To UBound(r) + 1, 1 To 8)
k = 0
For x = 0 To UBound(r)
k = k + 1
For j = 2 To 9 '读取遍历列
brr(k, j - 1) = arr(r(x), j)
Next j
Next x
Sheets("模板").Activate
[a2] = arr(r(x - 1), 2)
Range("b7", "i1000") = ""
With [B7].Resize(UBound(r) + 1, 8)
.Value = brr
.Borders.LineStyle = xlNone
.Borders.Weight = xlThin
.HorizontalAlignment = xlCenter
.Font.Size = 12
.Font.Name = "宋体"
End With
[a1].CurrentRegion.Select
ActiveWorkbook.EnvelopeVisible = True
With ActiveSheet.MailEnvelope
With .Item
.To = kr(i) '------------收件人
.Subject = "测试邮件" '------------主题
.Send
End With
End With
Next i
Application.ScreenUpdating = True '恢复屏幕更新
Set d = Nothing '释放字典
Set outApp = Nothing
MsgBox "共发送" & i & "封邮件！"
End Sub

复制代码

libaoshui · 发表于 2019-5-21 13:34

闻启学发表于 2019-5-20 21:50
有个疑问工资条一般都是一对一，除非你需求不是工资条

跟我来！一步一步教你批量发送邮件

谢谢答复。
当时在做批量邮件群发时，确实有参考您的教程。
这个场景其实是供应商对账单，WORD里有固定的模板，有公司名、合同编号、货品清单等。
在EXCEL里建模板（排版也不是EXCEL擅长的地方），排版效果不好。所以思考能不能用VBA调用WORD，把数据填进去，然后一条条发送。
4楼是自己思考的方法，可以实现在EXCEL批量群发邮件。

		自动登录	找回密码
密码			免费注册

[求助] 邮件合并之EXCEL与WORD联动

最新热点 /1