Excel VBA macro to send emails to unique users in range

send multiple emails from excel list vba
vba code to send email from excel to multiple recipients with attachment
excel macro send email to address in cell
excel macro to send email automatically
macro to send email from excel using outlook

I'm trying to create a VBA macro that will look into the A column, find all unique email addresses, create a new outlook email for each and populate the body of that email with the rows where that email is present (also including the header).

Example data:

+----------------+---------------------+---------+
|     Email      |     Application     | Version |
+----------------+---------------------+---------+
| test1@test.com | Microsoft_Office_13 | v2.0    |
| test1@test.com | Putty               | v3.0    |
| test1@test.com | Notepad             | v5.6    |
| test2@test.com | Microsoft_Office_13 | v2.0    |
| test2@test.com | Putty               | v3.0    |
| test2@test.com | Adobe_Reader        | v6.4    |
| test3@test.com | Microsoft_Office_13 | v3.6    |
| test3@test.com | Paint               | v6.4    |
| test3@test.com | Adobe_Reader        | v6.4    |
+----------------+---------------------+---------+

This is what I was able to find in my research, but it will create an email for every time the address is listed. It also doesn't really have any code which shows how to pull a range of cells into the body.

Sub Test1()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range

    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")

    On Error GoTo cleanup
    For Each cell In Columns("A").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" And _
           LCase(Cells(cell.Row, "C").Value) = "yes" Then

            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = cell.Value
                .Subject = "Reminder"
                .Body = "Hi, please find your account permissions below:"
                .Display
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    Next cell

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

The desired email output would be something like:

Hi, please find your account permissions below:

+----------------+---------------------+---------+
|     Email      |     Application     | Version |
+----------------+---------------------+---------+
| test2@test.com | Microsoft_Office_13 | v2.0    |
| test2@test.com | Putty               | v3.0    |
| test2@test.com | Adobe_Reader        | v6.4    |
+----------------+---------------------+---------+

I used the code from my answer mentioned in the comment and modified it. Create a class and name it AppInfo. Here you find how to do that

Option Explicit

Public app As String
Public version As String

Then put the following code into a module. The asumption is that the data is in the active sheet starting in A1 with the header Email, Application and Version.

Option Explicit

Sub Consolidate()

#If Early Then
    Dim emailInformation As New Scripting.Dictionary
#Else
    Dim emailInformation As Object
    Set emailInformation = CreateObject("Scripting.Dictionary")
#End If

    GetEmailInformation emailInformation
    SendInfoEmail emailInformation
End Sub


Sub GetEmailInformation(emailInformation As Object)

Dim rg As Range
Dim sngRow As Range

Dim emailAddress As String
Dim myAppInfo As AppInfo
Dim AppInfos As Collection

Set rg = Range("A1").CurrentRegion    ' Assuming the list starts in A1 and DOES NOT contain empty row
Set rg = rg.Offset(1).Resize(rg.Rows.Count - 1)    ' Cut the headings

    For Each sngRow In rg.Rows

        emailAddress = sngRow.Cells(1, 1)

        Set myAppInfo = New AppInfo
        With myAppInfo
            .app = sngRow.Cells(1, 2)
            .version = sngRow.Cells(1, 3)
        End With

        If emailInformation.Exists(emailAddress) Then
            emailInformation.item(emailAddress).Add myAppInfo
        Else
            Set AppInfos = New Collection
            AppInfos.Add myAppInfo
            emailInformation.Add emailAddress, AppInfos
        End If

    Next

End Sub
Sub SendInfoEmail(emailInformation As Object)

Dim sBody As String
Dim sBodyStart As String
Dim sBodyInfo As String
Dim sBodyEnd As String
Dim emailAdress As Variant
Dim colLines As Collection
Dim line As Variant

    sBodyStart = "Hi, please find your account permissions below:" & vbCrLf


    For Each emailAdress In emailInformation
        Set colLines = emailInformation(emailAdress)
        sBodyInfo = ""
        For Each line In colLines
            sBodyInfo = sBodyInfo & _
                         "Application: " & line.app & vbTab & "Version:" & line.version & vbCrLf
        Next
        sBodyEnd = "Best Regards" & vbCrLf & _
                   "Team"

        sBody = sBodyStart & sBodyInfo & sBodyEnd
        SendEmail emailAdress, "Permissions", sBody
    Next


End Sub

Sub SendEmail(ByVal sTo As String _
              , ByVal sSubject As String _
                , ByVal sBody As String _
                  , Optional ByRef coll As Collection)


    #If Early Then
        Dim ol As Outlook.Application
        Dim outMail As Outlook.MailItem
        Set ol = New Outlook.Application
    #Else
        Dim ol As Object
        Dim outMail As Object
        Set ol = CreateObject("Outlook.Application")
    #End If

    Set outMail = ol.CreateItem(0)

    With outMail
        .To = sTo
        .Subject = sSubject
        .Body = sBody
        If Not (coll Is Nothing) Then
            Dim item As Variant
            For Each item In coll
                .Attachments.Add item
            Next
        End If

        .Display
        '.Send
    End With

    Set outMail = Nothing

End Sub

How to send email to multiple recipients in a list from Excel via , I'm trying to create a VBA macro that will look into the A column, find all unique email addresses, create a new outlook email for each and  1. Setup. This macro simply copies a specified range over to Outlook, then hits the send button. Automating what you would normally do, if you wanted to send a table of data. I originally used a macro that took screen shots, and attached that to the email.

VBA Send Email from Excel, How do I send email from Excel VBA to multiple recipients? Send personalized mass emails to a list from Excel with VBA code. Excepting the Mail Merge function, the following VBA code also can do you a favor, please do as this: 1. Hold down the ALT + F11 keys, and it opens the Microsoft Visual Basic for Applications window. 2. Click Insert > Module, and paste the following code in the Module Window.

Simplest way, in my opinion, would be to format your table as a table in Excel (which will enable search and sort). Then you could do something like e.g.

email = "test1@test.com"
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set tbl = ws.ListObjects("Table1")
tbl.Range.AutoFilter Field:=1, Criteria1:=email
Set data = tbl.DataBodyRange
If (data.Rows.Count = 0) Then Exit Sub

If execution makes it past the check (data.Rows.Count > 0) then you can send a mailer using HTML:

Set app = CreateObject("Outlook.Application")
Set mail = OutApp.CreateItem(0)
bodyText = "<BODY style=font-size:11pt;font-family:Calibri>" & _
            " Hi, please find your account permissions below: <br> </BODY> "
With mail
    .To = email
    .Subject = "Email title here."
    .HTMLBody = bodyText & "<p>" & RangeToHTML(data)
    .Importance = 1 ' normal
    .Display
End With

which requires the following helper function:

Function RangeToHTML(rng As Range) As String

Dim fso As Object
Dim ts As Object
Dim tempFile As String
Dim tempWB As Workbook

    tempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set tempWB = Workbooks.Add(1)
    With tempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With tempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=tempFile, _
         Sheet:=tempWB.Sheets(1).name, _
         Source:=tempWB.Sheets(1).UsedRange.Offset(1).Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(tempFile).OpenAsTextStream(1, -2)
    RangeToHTML = ts.ReadAll
    ts.Close
    RangeToHTML = Replace(RangeToHTML, _
                    "align=center x:publishsource=", "align=left x:publishsource=")

    tempWB.Close savechanges:=False
    Kill tempFile

    Set ts = Nothing
    Set fso = Nothing
    Set tempWB = Nothing

End Function

You can modify as needed.

Sending Email to a List of Recipients Using Excel and Outlook , code. 1. Hold down the ALT + F11 keys to open the Microsoft Visual Basic for Applications window. Press the F5 key to run the code. In the opening Kutools for Excel dialog box, please select the range which contains the email addresses you will send emails to, and then click the OK button.

VBA macro to send a email to one of a list of emails, How do I send an email to specified in a cell in Excel? The following VBA code can help you to send your selected range as attachment in Excel. Please do as this: Kutools for Excel, with more than 120 handy functions, makes your jobs easier. Free Trial 60 days. 1. Open your workbook and then hold down the ALT + F11 keys to open the Microsoft Visual Basic for Applications window.

How to send / email range of cells through outlook from Excel?, The recipient email addresses must be in column A, and the body text of the Books, Holy Macro! It's 2,500 Excel VBA Examples. VB Copy. I am trying to set up several buttons on an Excel form to email different groups of people. Stack Overflow Public Excel VBA macro to send emails to unique

How to send email with copying and pasting a specified range into , VBA macro to send to one of a list of emails. send emails from excel. Use vlookup in a macro Duration: 8:33 Posted: Feb 23, 2017 Takes the Range provided by you and copy it as a Picture Creates a Temp worksheet and add a Chart and paste this image in to a Blank Chart Now export this chart as an Image and save it to a temp folder Create your mail in Outlook and Draft your Mail in HTML as shown in the above code and then send the email.

Comments
  • Maybe this is of help
  • This worked great! Is it possible to insert their permissions as a table in the email?
  • Yes, I think so. Feel free to change the Sub SendEmail resp SendInfoMail accordingly.
  • Any idea how to pull the whole column? It seems that the code sets and then calls variables for each column, but I'm hoping to pull all the columns of all the rows which contain this email address in the column.
  • Yes but I think it's now a good time to try something on your own. If you get stuck post a new question.