Macro to send to multiple recipients

[csch123]

Hello,

I have a macro in place at work that currently sends a file to only one recipient. I have been asked to start sending the same file to multiple people. My current macro can only send to one recipient at a time, but I am uncertain as to how to add more to the list. For example, I want one email with an attachment sent to three people rather than sending the email three times to each individual person.

I am attaching my current macro code. I attempted to add multiple recipients in column B, but that didn't seem to work. I am kind of stumped. I am not sure how to add this code into a code box.

Sub Macro2()
'
' Macro2 Macro
'
    Dim Response As VbMsgBoxResult
    Response = MsgBox("Are you sure you want to send the emails?", vbQuestion + vbYesNo)
    If Response = vbNo Then Exit Sub
    Range("B5").Select
    Do
        Dim aOutlook As Outlook.Application, aEmail As Outlook.MailItem
        Set aOutlook = GetObject(, "Outlook.Application")
        If aOutlook Is Nothing Then Set aOutlook = New Outlook.Application
        Set aEmail = aOutlook.CreateItem(olMailItem)
        aEmail.Subject = ActiveCell.Offset(0, 1)
        aEmail.Body = Range("E5") & Chr(13) & Chr(13) & Range("E6") & Chr(13) & Chr(13) & Range("E7") & Chr(13) & Chr(13) & Range("E8") & Chr(13) & Range("E9") & Chr(13) & Range("E10") & Chr(13) & Range("E11") & Chr(13) & Range("E12")
        aEmail.Recipients.Add ActiveCell.Text
        aEmail.Attachments.Add ActiveCell.Offset(0, 2).Text
        aEmail.Send
        ActiveCell.Offset(1, 0).Select
    Loop Until IsEmpty(ActiveCell.Offset(0, 0))
    MsgBox "All emails have been sent", vbInformation
    '
End Sub

 

[Zack Barresse]

Hi there, welcome to the board!

I would change what you're doing right now. As it stands you're creating a reference to the same outlook object every time, as it's within the Do/Loop. Instead, set it outside of the loop, then create your emails inside of it.

As far as your request for adding multiple recipients, it depends on how your data is structured. I have somewhat of an idea from your code, but that doesn't tell me the whole story. Are the email addresses you want to send on one email in different rows? The same row? Which columns? If different rows, what is the logic for finding them?

Without knowing anything else, I would change the above code slightly...

Option Explicit

Dim bOLOpen As Boolean

Sub Macro2()

    Dim aOutlook As Outlook.Application, aEmail As Outlook.MailItem
    Dim WS As Worksheet, Response As VbMsgBoxResult
    Dim iRow As Long, iCol As Long, sBody As String
    Response = MsgBox("Are you sure you want to send the emails?", vbQuestion + vbYesNo)
    If Response = vbNo Then Exit Sub
    iCol = 2
    iRow = 5

    Set aOutlook = OpenOutlook()
    If aOutlook Is Nothing Then Exit Sub
    Set WS = ActiveSheet
    sBody = SetEmailBody(WS)
    
    Do
        Set aEmail = aOutlook.CreateItem(olMailItem)
        aEmail.Subject = WS.Cells(iRow, iCol + 1).Value
        aEmail.Body = sBody
        aEmail.Recipients.Add WS.Cells(iRow, iCol).Text
        aEmail.Recipients.ResolveAll
        aEmail.Attachments.Add WS.Cells(iRow, iCol + 2).Text
        aEmail.Send
        iRow = iRow + 1
        Set aEmail = Nothing
    Loop Until IsEmpty(WS.Cells(iRow, iCol).Value)

    If bOLOpen = False Then aOutlook.Quit
    Set aOutlook = Nothing
    Set aEmail = Nothing

    MsgBox "All emails have been sent", vbInformation

End Sub

Function SetEmailBody(ByVal WKS As Worksheet) As String
    SetEmailBody = WKS.Range("E5").Value & String(2, Chr(13)) & WKS.Range("E6").Value & String(2, Chr(13))
    SetEmailBody = SetEmailBody & WKS.Range("E7").Value & String(2, Chr(13)) & WKS.Range("E8").Value
    SetEmailBody = SetEmailBody & Chr(13) & WKS.Range("E9").Value & Chr(13) & WKS.Range("E10").Value
    SetEmailBody = SetEmailBody & Chr(13) & WKS.Range("E11").Value & Chr(13) & WKS.Range("E12").Value
End Function

Function OpenOutlook() As Object
    Dim OutlookOpen As Object
    On Error Resume Next
    Set OutlookOpen = GetObject(, "Outlook.Application")
    bOLOpen = True
    If OutlookOpen Is Nothing Then
        Set OutlookOpen = CreateObject("Outlook.Application")
        bOLOpen = False
    End If
    Set OpenOutlook = OutlookOpen
    On Error GoTo 0
End Function

 

[csch123]

Thank you very much. I was able to find a work around, but I am going to try to implement your code into the work around. This is a big help, Zack.