将EXCEL内容拆分成多个工作薄后发送给不同人

黄雨森

按条件拆分工作表并发送给不同人.zip (8.83 KB, 下载次数: 100)

2014-5-30 13:08 上传

点击文件名下载附件
按条件拆分工作表并发送给不同人

要求：
     1、按公司人员发名册表中B列数据，将其拆分为多个EXCEL文件（保留表头），文件名为公司名称，拆分后的EXCEL表默认存储在当前工作表存储路径下
     2、将拆分后的EXCEL文件，按Mail表中所列的列表，分别自动发送给不同的人，主题相应的不同   
     3、邮件默认以OUTLOOK发送                                                                                                                           

请各位老师帮忙用VBA做一下，谢谢！

黄雨森

老师，过完节了，帮忙看看这个啊，谢谢！

VBA万岁

黄雨森 发表于 2014-6-3 09:27
老师，过完节了，帮忙看看这个啊，谢谢！

路过，支持一下。

zhenghui13

是按班级拆分成不同workbook,然后发送吗?发送给谁呢?
请测试一下代码是否可行,EMAIL会保存在草稿箱里.

1. 
   
2. 
   
3. 
   
4. Sub ExcelSplit()
   
5. '---------------Define BILL Split
   
6. Dim cnn As Object, sql$
   
7. Dim arr, brr, m
   
8. Dim wb As Workbook
   
9. '---------------Define Outlook
   
10. Dim wbStr As String, nlist As String
    
11. Dim OutlookApp
    
12. Dim newMail
    
13. Set OutlookApp = CreateObject("Outlook.Application")
    
14. Dim dic, n, k, j
    
15. Set dic = CreateObject("Scripting.Dictionary")
    
16. '----------------run split
    
17. Application.ScreenUpdating = False
    
18. With Sheet1
    
19. arr = .Range("A1", "E2") 'ARRAY for Title
    
20. Set cnn = CreateObject("Adodb.Connection")
    
21. cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;" _
    
22. & "Data Source=" & ThisWorkbook.FullName
    
23. sql = "select distinct °à¼¶ from [×ܱí$A2:E] where °à¼¶ is not NULL"
    
24. '--check File number and name only
    
25. 'Sheet2.[a1].CopyFromRecordset cnn.Execute(sql)
    
26. brr = cnn.Execute(sql).getrows
    
27. End With
    
28. '----------------------------------
    
29. For n = 2 To Sheet2.[A65536].End(xlUp).Row
    
30. dic(Range("A" & n).Value) = Range("B" & n).Value
    
31. Next
    
32. '----------------------------------
    
33. For m = 0 To UBound(brr, 2)
    
34. Set wb = Workbooks.Add
    
35. sql = "select * from [×ܱí$A2:E] where °à¼¶='" & brr(0, m) & "'"
    
36. wb.Sheets(1).[a3].CopyFromRecordset cnn.Execute(sql)
    
37. wb.Sheets(1).Range("A1", "E2") = arr
    
38. wb.SaveAs ThisWorkbook.Path & "" & brr(0, m) & ".xlsx"
    
39. k = dic(brr(0, m))
    
40. 
    
41. '---------------run OUTLOOK EMAIL--------------
    
42. wbStr = ActiveWorkbook.FullName
    
43. ActiveWorkbook.Close
    
44. Set newMail = OutlookApp.CreateItem(olMailItem)
    
45. With newMail
    
46. .Subject = "Records"
    
47. .Body = "Please help to find Record Inforamtion of your class"
    
48. Set myAttachments = newMail.Attachments
    
49. myAttachments.Add wbStr, olByValue, 1, "workbook"
    
50. .to = k
    
51. '.To = Replace(Join(k, ";"), " ", "")
    
52. .Save
    
53. End With
    
54. 
    
55. k = ""
    
56. 'ActiveWorkbook.Close
    
57. Set newMail = Nothing
    
58. Next
    
59. dic.RemoveAll
    
60. Application.ScreenUpdating = True
    
61. cnn.Close: Set cnn = Nothing
    
62. Set OutlookApp = Nothing
    
63. 
    
64. End Sub

复制代码

黄雨森

zhenghui13 发表于 2014-6-3 15:10
是按班级拆分成不同workbook,然后发送吗?发送给谁呢?
请测试一下代码是否可行,EMAIL会保存在草稿箱里.

非常感谢！刚测试了一下，没什么问题，谢谢！
还有一个问题想问一下，邮件可以自动发送吗（不保存在草稿箱）？这个要怎么设置呢？
如果有多个收件人呢，怎么调整，谢谢！

黄雨森

zhenghui13 发表于 2014-6-3 15:10
是按班级拆分成不同workbook,然后发送吗?发送给谁呢?
请测试一下代码是否可行,EMAIL会保存在草稿箱里.

邮件自动发送已经解决了，还有两个小问题：
    1、多个收件人，如一班附件可能需要发送给多个人
    2、不同附件，主题不同，如发送一班附件、二班附件的主题可能会不同
还请帮忙再看看，谢谢！

VBA万岁

黄雨森 发表于 2014-6-4 10:13
非常感谢！刚测试了一下，没什么问题，谢谢！
还有一个问题想问一下，邮件可以自动发送吗（不保存在草稿 ...

将 .Save改为 .Send即可自动发送。

VBA万岁

黄雨森 发表于 2014-6-4 10:13
非常感谢！刚测试了一下，没什么问题，谢谢！
还有一个问题想问一下，邮件可以自动发送吗（不保存在草稿 ...

如果有多个收件人，可将多个收件人的邮箱地址用分号隔开填入EAddress表中的B列相应单元格，代码不变。

zhenghui13

a.直接发送,把.save改成.send试试;
b.设置多个收件人的话,先要有一个EMAL列表对应相匹配的文件,然后把字典放在循环里面试试.

黄雨森

谢谢上面两位老师！我自己再试试吧！刚才发现上传的附件有问题，狂汗，谢谢啦！