表拆分，然后发送不同邮箱

chenxiaoshuang

各位老师好，如附件总表，现想根据B列客户名进行表拆分，拆分后每个工作表以客户名命名，拆分后的工作表根据总表中的邮箱发送给指定邮箱号，求大神指点

闻启学

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

看看 这个帖子 最后一个

libaoshui

闻启学 发表于 2019-3-18 22:35
跟我来！  一步一步教你批量发送邮件
http://club.excelhome.net/thread-1158003-1-1.html
(出处: ExcelH ...

感谢帮助，谢谢支持！

小花鹿

楼主工作表工作薄分不清
拆分好办
发邮件我的经验是用JMAIL

libaoshui

1. Sub SendMailEnvelope_2()  '邮件群发
   
2. Dim d As Object, arr, brr, r, kr, i&, j&, k&, x&, Mystr$
   
3. Set d = CreateObject("scripting.dictionary") 'set字典
   
4. arr = Sheets("工资表").UsedRange '总表的数据区域
   
5. For i = 2 To UBound(arr) '遍历数组arr
   
6.     Mystr = arr(i, 1) '统一转换为字符串格式
   
7.     If Not d.exists(Mystr) Then
   
8.         d(Mystr) = i '字典中不存在关键词则将行号装入字典
   
9.     Else
   
10.         d(Mystr) = d(Mystr) & "," & i '如果存在则合并行号，以逗号间隔
    
11.     End If
    
12. Next
    
13. kr = d.keys '字典的key集
    
14. Application.ScreenUpdating = False '关闭屏幕刷新
    
15. For i = 0 To UBound(kr) '遍历字典key值
    
16.     r = Split(d(kr(i)), ",") '取出item里储存的行号
    
17.     ReDim brr(1 To UBound(r) + 1, 1 To 9) '声明放置结果的数组brr
    
18.     k = 0
    
19.     For x = 0 To UBound(r)
    
20.         k = k + 1 '累加记录行数
    
21.         For j = 1 To 9 '读取遍历列
    
22.             brr(k, j) = arr(r(x), j)
    
23.         Next j
    
24.     Next x
    
25.     Sheets("使用MailEnvelope发送邮件").Activate
    
26.     [a1].CurrentRegion.Offset(1).ClearContents
    
27.     [a2].Resize(UBound(r) + 1, 9) = brr
    
28.     [a1].CurrentRegion.Select
    
29.     ActiveWorkbook.EnvelopeVisible = True
    
30.     With ActiveSheet.MailEnvelope
    
31.         .Introduction = "您好：" & vbCrLf & "以下是您工资明细，请查收！"  '------------邮件正文内容
    
32.         With .Item
    
33.             .To = kr(i) '------------收件人
    
34.             '.CC = "treasurer@gmail.com"  '------------抄送人
    
35.             .Subject = "工资明细" '------------主题
    
36.             .Send              '------------发送邮件
    
37.         End With
    
38.     End With
    
39. Next i
    
40. ActiveWorkbook.EnvelopeVisible = False
    
41. Application.ScreenUpdating = True '恢复屏幕更新
    
42. Set d = Nothing '释放字典
    
43. MsgBox "邮件发送成功！"
    
44. End Sub

复制代码

libaoshui

1. <blockquote>Option Explicit

复制代码

禾叶花

非常感谢楼上大神。