VBA Excel发送单个电子邮件

我有以下代码对我来说工作得很好。 它将“NAMES”列(第I列)中的名称进行整理,以根据其他单元格(L,K)中的条件生成电子邮件列表,并使用表单中的一些内容生成邮件正文,以便将其发送到列表的收件人。

我现在有要求发送个人电子邮件,而不是发送给每个人的一封电子邮件。 我现在可以通过过滤第一列的名称来完成这项工作,但是如果有100个名字的话,那也是有点烦人的…任何方式我都可以改变代码,使它为收件人生成单独的电子邮件?

ps欣赏代码可能有点杂乱/没有优化,但我是一个新手…谢谢

Sub SendEmail() Dim OutlookApp Dim MItem Dim cell As Range Dim Subj As String Dim EmailAddr As String Dim Recipient As String Dim Msg As String Dim Projects As String Dim ProjectsMsg As String 'Create Outlook object Set OutlookApp = CreateObject("Outlook.Application") Set MItem = OutlookApp.CreateItem(0) 'Loop through the rows For Each cell In Columns("I").Cells.SpecialCells(xlCellTypeVisible) If cell.Value <> "" And _ (Cells(cell.Row, "L").Value) = "No" And (Cells(cell.Row, "K").Value) <> "Yes" Then 'first build email address EmailAddr = LCase$(Replace(cell.Value, " ", ".")) & "@company.com" 'then check if it is in Recipient List build, if not, add it, otherwise ignore If InStr(1, Recipient, EmailAddr) = 0 Then Recipient = Recipient & ";" & EmailAddr End If Next Recipient = Mid(Recipient, 2) For Each cell In Columns("C").Cells.SpecialCells(xlCellTypeVisible) If cell.Value <> "" And _ (Cells(cell.Row, "L").Value) = "No" And (Cells(cell.Row, "K").Value) <> "Yes" And _ (Cells(cell.Row, "I").Value) <> "" Then Projects = vbCrLf & "Document: " & Cells(cell.Row, "B").Value & "; " & Cells(cell.Row, "C").Value & "; " & "Rev " & Cells(cell.Row, "G").Value & "; " & Cells(cell.Row, "I").Value If InStr(1, ProjectsMsg, Projects) = 0 Then ProjectsMsg = ProjectsMsg & Projects & vbCrLf End If Next Msg = "Please review the following: " & ProjectMsg Subj = "Outstanding Documents to be Reviewed" 'Create Mail Item and view before sending Set MItem = OutlookApp.CreateItem(olMailItem) With MItem .To = Recipient 'full recipient list .Subject = Subj .Body = Msg .display End With End Sub 

我认为你希望做的是把收件人列表放入电子邮件,然后让电子邮件为每个人生成一个不同的电子邮件。 它不是这样的。

相反,移动代码,使循环内的电子邮件,以便您每次生成一个新的电子邮件,并发送它。 首先创build项目消息,并首先让他们准备好电子邮件。

 Sub SendEmail() Dim OutlookApp Dim MItem Dim cell As Range Dim Subj As String Dim EmailAddr As String Dim PriorRecipients As String Dim Msg As String Dim Projects As String Dim ProjectsMsg As String 'Create Outlook object Set OutlookApp = CreateObject("Outlook.Application") PriorRecipients = "" 'First create the body for the message For Each cell In Columns("C").Cells.SpecialCells(xlCellTypeVisible) If cell.Value <> "" And _ (Cells(cell.Row, "L").Value) = "No" And (Cells(cell.Row, "K").Value) <> "Yes" And _ (Cells(cell.Row, "I").Value) <> "" Then Projects = vbCrLf & "Document: " & Cells(cell.Row, "B").Value & "; " & Cells(cell.Row, "C").Value & "; " & "Rev " & Cells(cell.Row, "G").Value & "; " & Cells(cell.Row, "I").Value If InStr(1, ProjectsMsg, Projects) = 0 Then ProjectsMsg = ProjectsMsg & Projects & vbCrLf End If Next Msg = "Please review the following: " & ProjectMsg Subj = "Outstanding Documents to be Reviewed" 'Loop through each person and send email if they haven't already received one. For Each cell In Columns("I").Cells.SpecialCells(xlCellTypeVisible) If cell.Value <> "" And _ (Cells(cell.Row, "L").Value) = "No" And (Cells(cell.Row, "K").Value) <> "Yes" Then 'first build email address EmailAddr = LCase$(Replace(cell.Value, " ", ".")) & "@company.com" 'then check if it is in Recipient List build, if not, add it, otherwise ignore 'If the recipient has already received an email, skip If InStr(1, PriorRecipients, EmailAddr) <> 0 Then GoTo NextRecipient End If PriorRecipients = PriorRecipients & ";" & EmailAddr 'Create Mail Item and view before sending Set MItem = OutlookApp.CreateItem(olMailItem) With MItem .To = EmailAddr 'single email address .Subject = Subj .Body = Msg .display 'This will show for EVERY person. Skip this and change to .send to just send without showing the email. End With End If NextRecipient: Next End Sub