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

VBA万岁

黄雨森 发表于 2014-6-4 10:58
邮件自动发送已经解决了，还有两个小问题：
    1、多个收件人，如一班附件可能需要发送给多个人
    2 ...

主题不同，可将
.Subject = "Records"
改为：
.Subject = brr(0, m) & "Records"

VBA万岁

VBA万岁 发表于 2014-6-4 11:42
主题不同，可将
.Subject = "Records"
改为：

在草稿箱测试效果如下：

黄雨森

从哪里可以给分啊？为什么我给不了呢？

黄雨森

zhenghui13 发表于 2014-6-4 11:13
a.直接发送,把.save改成.send试试;
b.设置多个收件人的话,先要有一个EMAL列表对应相匹配的文件,然后把字典 ...

我自己倒腾了一下，还是不行，能帮我再修改一下吗？谢谢！附件中添加了多个收件人还有主题和正文示例，多谢了！
如果可以的话，能给程序加一下注释吗？谢谢！
找了半天，不知道怎么给分，感谢了！

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

2014-6-4 13:17 上传

点击文件名下载附件
数据

jiminyanyan

VBA万岁 发表于 2014-6-4 11:51
在草稿箱测试效果如下：

能用闪电邮发送么。。。。

VBA万岁

jiminyanyan 发表于 2014-6-4 13:33
能用闪电邮发送么。。。。

我不会，如果大侠会的话，可否赐教？

VBA万岁

黄雨森 发表于 2014-6-4 13:17
我自己倒腾了一下，还是不行，能帮我再修改一下吗？谢谢！附件中添加了多个收件人还有主题和正文示例，多 ...

请测试：
Sub ExcelSplit2()
'---------------Define BILL Split
Dim cnn As Object, sql$
Dim arr, brr, m
Dim wb As Workbook
'---------------Define Outlook
    Dim wbStr As String, nlist As String
    Dim OutlookApp
    Dim newMail
    Set OutlookApp = CreateObject("Outlook.Application")
    Dim dic, n, k, j
    Dim c As Long, subj
   Set dic = CreateObject("Scripting.Dictionary")
'----------------run split
Application.ScreenUpdating = False
With Sheet1
arr = .Range("A1", "E2") 'ARRAY for Title
Set cnn = CreateObject("Adodb.Connection")
cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;" _
            & "Data Source=" & ThisWorkbook.FullName
sql = "select distinct 班级 from [总表$A2:E] where 班级 is not NULL"
'--check File number and name only
'Sheet2.[a1].CopyFromRecordset cnn.Execute(sql)
brr = cnn.Execute(sql).getrows
End With
'----------------------------------
ReDim subj(0 To [A65536].End(xlUp).Row - 5)
For n = 2 To [A65536].End(xlUp).Row - 4
    For c = 4 To Cells(n, Cells.Columns.Count).End(xlToLeft).Column
        subj(n - 2) = subj(n - 2) & Cells(n, c) & ";"
    Next c
    subj(n - 2) = Mid(subj(n - 2), 1, Len(subj(n - 2)) - 1)
    dic(Range("A" & n).Value) = subj(n - 2)
Next
'----------------------------------
For m = 0 To UBound(brr, 2)
    Set wb = Workbooks.Add
    sql = "select * from [总表$A2:E] where 班级='" & brr(0, m) & "'"
    wb.Sheets(1).[a3].CopyFromRecordset cnn.Execute(sql)
    wb.Sheets(1).Range("A1", "E2") = arr
    wb.SaveAs ThisWorkbook.Path & "\" & brr(0, m) & ".xlsx"
    k = dic(brr(0, m))

'---------------run OUTLOOK EMAIL--------------
    wbStr = ActiveWorkbook.FullName
    ActiveWorkbook.Close
         Set newMail = OutlookApp.CreateItem(olMailItem)
         With newMail
            .Subject = Format(Date, "yymmdd") & brr(0, m)
            .Body = "请查收" & brr(0, m) & "成绩，谢谢！"
            Set myAttachments = newMail.Attachments
                myAttachments.Add wbStr, olByValue, 1, "workbook"
            .To = k
            '.To = Replace(Join(k, ";"), " ", "")
            .Save
          End With
         
      k = ""
     'ActiveWorkbook.Close
     Set newMail = Nothing
  Next
     dic.RemoveAll
Application.ScreenUpdating = True
cnn.Close: Set cnn = Nothing
Set OutlookApp = Nothing

End Sub

VBA万岁

VBA万岁 发表于 2014-6-4 15:20
请测试：
Sub ExcelSplit2()
'---------------Define BILL Split

草稿箱测试效果：

黄雨森

VBA万岁 发表于 2014-6-4 15:20
请测试：
Sub ExcelSplit2()
'---------------Define BILL Split

可以了，谢谢！终于弄成了，太感谢了！

黄雨森

VBA万岁 发表于 2014-6-4 15:25
草稿箱测试效果：

老师，你好！
我自己学习了一下这段代码，有些地方不知道是什么意思，可以帮忙看看吗？谢谢！

例如：  ReDim addr(0 To [A65536].End(xlUp).Row - 5)
           For n = 2 To [A65536].End(xlUp).Row - 4
                 For c = 6 To Cells(n, Cells.Columns.Count).End(xlToLeft).Column
                      addr(n - 2) = addr(n - 2) & Cells(n, c) & ";"
                Next c
                addr(n - 2) = Mid(addr(n - 2), 1, Len(addr(n - 2)) - 1)
                dic(Range("b" & n).Value) = addr(n - 2)
           Next

这段中的 addr(0 To [A65536].End(xlUp).Row - 5) 为什么要减5呢？我试过减去其他值时就没法获取结果，请帮解答一下谢谢！