Sending two different emails to two different recipients with single button using vba

Hello,

I am trying to use one button to send multiple emails to two different people. The messages and email addresses are in cells in the spread sheet, so I refer to them as ranges. When I click the button, the first email goes out perfectly, but the second one never sends. Can someone please help me? Here is what I have so far:

Private Sub FillOutNewHireForm_Click()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim Body1 As Range
    Dim Body2 As Range
    Dim Hire As Range
    Dim Email1 As Range
    Dim Email2 As Range
    
    
    Set Email1 = Worksheets("Tasks").Range("K5")
    
    Set Email2 = Worksheets("Tasks").Range("L5")
    
    Set Hire = Worksheets("Tasks").Range("C1")

    Set Body1 = Worksheets("Tasks").Range("F5")
    
    Set Body2 = Worksheets("Tasks").Range("G5")

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = Email1
        .CC = ""
        .BCC = ""
        .Subject = "New-Hire task: Fill out New-Hire Form for " & Hire
        .Body = Body1
        .Attachments
         'You can add other files also like this
         '.Attachments.Add ("C:\test.txt")

        .Send
        
    End With
   
   
    On Error Resume Next
    With OutMail
        .To = Email2
        .CC = ""
        .BCC = ""
        .Subject = "New-Hire task: Please share Personal Folder with " & Hire
        .Body = Body2
        .Attachments
         'You can add other files also like this
         '.Attachments.Add ("C:\test.txt")

        .Send
    End With
    On Error GoTo 0
    
    
    MsgBox ("Email Sent")
    
    Range("A5").Value = "Complete"
    
    ThisWorkbook.Save
    
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Hello ahowe,

Welcome to the Forum!

Remove the On Error Resume and On Error Goto statements. If your macro is written correctly, you will not have any errors.

If you do receive an error, note the error number and the message. Post both of these should an error occur. It will make it easier to fix the problem.

Hello ahowe,

Okay, let's try replacing the Send with Display. This will open Outlook and display the email. Let me know what happens.

Hello ahowe,

After looking closer at your code, I saw a few mistakes. Try this version.

Private Sub FillOutNewHireForm_Click()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim Body1 As Range
    Dim Body2 As Range
    Dim Hire As Range
    Dim Email1 As Range
    Dim Email2 As Range
    
    
    Set Email1 = Worksheets("Tasks").Range("K5")
    
    Set Email2 = Worksheets("Tasks").Range("L5")
    
    Set Hire = Worksheets("Tasks").Range("C1")

    Set Body1 = Worksheets("Tasks").Range("F5")
    
    Set Body2 = Worksheets("Tasks").Range("G5")

    Set OutApp = CreateObject("Outlook.Application")
    
    OutApp.Session.Logon
    OutApp.Session.GetDefaultFolder 6
    
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = Email1
        .CC = ""
        .BCC = ""
        .Subject = "New-Hire task: Fill out New-Hire Form for " & Hire
        .Body = Body1
        .Send
        
    End With
   
    With OutMail
        .To = Email2
        .CC = ""
        .BCC = ""
        .Subject = "New-Hire task: Please share Personal Folder with " & Hire
        .Body = Body2
        .Send
    End With
    
    MsgBox ("Email Sent")
    
    Range("A5").Value = "Complete"
    
    ThisWorkbook.Save
    
    Set OutMail = Nothing
    Set OutApp = Nothing
    
End Sub

Hello ahowe,

Can you post the workbook?

How To Post Your Workbook

1. At the bottom right of the Reply window, Click the button Go Advanced
2. At the top of the Your Message Window, in the first row of icons, Click the Paperclip icon.
3. Click the Add Files button at the top right in the dialog box. This displays the File Manager dialog.
4. Click the Select Files button at the bottom middle of the dialog.
5. In the new window Find the file you want to upload, select it, and Click Open.
6. You will now be back in the File Manager dialog. Click the bottom Middle button Upload File.
7. Wait until the file has completely uploaded before you exit the File Manager dialog.

Hello ahowe

I forgot that after an email is sent, Outlook sets the object to Nothing. It must be created again or an error will occur. This code works.

Private Sub FillOutNewHireForm_Click()

    Dim OutApp As Object
    Dim Body1 As Range
    Dim Body2 As Range
    Dim Hire As Range
    Dim Email1 As Range
    Dim Email2 As Range
    
    
    Set Email1 = Worksheets("Tasks").Range("K5")
    
    Set Email2 = Worksheets("Tasks").Range("L5")
    
    Set Hire = Worksheets("Tasks").Range("C1")

    Set Body1 = Worksheets("Tasks").Range("F5")
    
    Set Body2 = Worksheets("Tasks").Range("G5")

    Set OutApp = CreateObject("Outlook.Application")
    
    OutApp.Session.Logon
    OutApp.Session.GetDefaultFolder 6

    
    With OutApp.CreateItem(0)
        .To = Email1
        .CC = ""
        .BCC = ""
        .Subject = "New-Hire task: Fill out New-Hire Form for " & Hire
        .Body = Body1
        .Send
    End With
       
  
    With OutApp.CreateItem(0)
        .To = Email2
        .CC = ""
        .BCC = ""
        .Subject = "New-Hire task: Please share Personal Folder with " & Hire
        .Body = Body2
        .Send
    End With
      
    
    MsgBox ("Email Sent")
    
    Range("A5").Value = "Complete"
    
    ThisWorkbook.Save
    
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub