Question

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

我现在要求在个别电子邮件中发送，而不是发送给每个人的电子邮件。我现在可以通过使用名称过滤第I列来实现此目的，但如果有100个名称，那就有点烦人了......我可以改变代码以使其为收件人生成单独的电子邮件吗？

P.S。感谢代码可能有点凌乱/没有优化，但我是新手...谢谢

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

VBA Excel发送个人电子邮件

1 个答案: