VBA Excel 发送个人电子邮件

Question

我有以下代码，对我来说非常好用。 它整理“名称”列（第 I 列）中的名称，以根据其他单元格（L、K）中的条件生成电子邮件列表，并生成包含工作表中一些内容的消息正文，因此我可以将其发送到列表的收件人。

我现在需要通过单独的电子邮件发送它，而不是发送给每个人的一封电子邮件。我现在可以通过使用名称过滤列 I 来做到这一点，但是如果有 100 个名称，那就有点烦人了……我可以更改代码以使其为收件人生成单独的电子邮件吗？

附言欣赏代码可能有点混乱/没有优化，但我是新手......谢谢

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

Answer 1

我认为您希望做的是将收件人列表放入电子邮件中，然后让电子邮件为每个人生成不同的电子邮件。它不太像这样工作。

相反，移动代码以在循环中生成电子邮件，以便您每次生成新电子邮件并发送它。首先创建项目消息和主题，以便他们准备好接收电子邮件。

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