VBA Excel Sending Individual Emails

Question

I have the following code which works perfectly fine for me. It collates names in the "NAMES" column (column I) to generate a list of emails depending on criteria in other cells (L, K) and generates a message body with some stuff from the sheet, so I could send it to the list of recipients.

I now have a requirement to send out it in individual emails, rather than one email which is sent to everyone. I can do this now by filtering column I with names, but it's kinda annoying if there are like 100 names... Any way I can alter the code to make it generate individual emails for recipients ?

ps Appreciate the code may be a bit messy/not optimised, but I'm a novice...Thanks

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

I think what you are hoping to do is put the recipient list into the email and then have the email generate a different email for each person. It doesn't quite work like this.

Instead, move the code to make the email inside the loop so that you generate a new email each time and send it. Create the Project Msg first and subject first so that they're ready for the email.

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