Macro Edit - Email message creator

[psrs0810]

I need some assistance on editing a macro. I have utilized the macro below for a while - however, the way it is set up, if one person is to receive more than one attachment, I have them listed multiple times. How can I change this that if an individual is listed more than one time that they only get 1 email with multiple attachments?

Any help is appreciated.
Thank you

Sub Mailer()
Dim rngMailInfo As Range, rngCell As Range
Dim objApp As Object
Dim objMail As Object
Set rngMailInfo = Intersect(ActiveSheet.UsedRange, Range("B4:F" & Rows.Count))
Set objApp = CreateObject("Outlook.Application")
For Each rngCell In rngMailInfo.Resize(, 1)
On Error Resume Next
Set objMail = objApp.CreateItem(0)
With objMail
.To = rngCell(, 2).Text
.Subject = rngCell(, 3).Text
.Body = "" & rngCell.Text & vbCrLf & rngCell(, 5).Text
.Attachments.Add rngCell(, 4).Text
.Save
End With
Set objMail = Nothing
On Error GoTo 0
Next rngCell
Set objApp = Nothing
End Sub

 

[aaewalsh]

Try this:

Sub Mailer()
    Dim rngMailInfo As Range, rngCell As Range
    Dim objApp As Object
    Dim objMail As Object
    Dim recipients As Object ' Dictionary to track recipients
    Set rngMailInfo = Intersect(ActiveSheet.UsedRange, Range("B4:F" & Rows.Count))
    Set objApp = CreateObject("Outlook.Application")
    Set recipients = CreateObject("Scripting.Dictionary")
    For Each rngCell In rngMailInfo.Resize(, 1)
        On Error Resume Next
        If Not recipients.Exists(rngCell(, 2).Text) Then
            ' Add new recipient to dictionary
            Set objMail = objApp.CreateItem(0)
            objMail.To = rngCell(, 2).Text
            objMail.Subject = rngCell(, 3).Text
            objMail.Body = "" & rngCell.Text & vbCrLf & rngCell(, 5).Text
            recipients.Add rngCell(, 2).Text, objMail
        Else
            ' Add attachment to existing recipient
            recipients(rngCell(, 2).Text).Attachments.Add rngCell(, 4).Text
        End If
        On Error GoTo 0
    Next rngCell
    ' Send all emails with grouped attachments
    For Each key In recipients.Keys
        recipients(key).Save
    Next
    Set objApp = Nothing
    Set recipients = Nothing
End Sub

 

[psrs0810]

This does work!
I did notice that if the first line of a person has an attachment, it skips it. Is there a way to include that first line?

 

[aaewalsh]

Try This:

Sub Mailer()
    Dim rngMailInfo As Range, rngCell As Range
    Dim objApp As Object
    Dim objMail As Object
    Dim recipients As Object ' Dictionary to track recipients
    Set rngMailInfo = Intersect(ActiveSheet.UsedRange, Range("B4:F" & Rows.Count))
    Set objApp = CreateObject("Outlook.Application")
    Set recipients = CreateObject("Scripting.Dictionary")
    For Each rngCell In rngMailInfo.Resize(, 1)
        On Error Resume Next
        If Not recipients.Exists(rngCell(, 2).Text) Then
            ' Create new Outlook Mail Item
            Set objMail = objApp.CreateItem(0)
            objMail.Attachments.Add rngCell(, 4).Text
            objMail.To = rngCell(, 2).Text
            objMail.Subject = rngCell(, 3).Text
            objMail.Body = "" & rngCell.Text & vbCrLf & rngCell(, 5).Text
            recipients.Add rngCell(, 2).Text, objMail
        Else
            ' Add attachment to existing recipient
            recipients(rngCell(, 2).Text).Attachments.Add rngCell(, 4).Text
        End If
        On Error GoTo 0
    Next rngCell
    ' Send all emails with grouped attachments
    For Each key In recipients.Keys
        recipients(key).Save
    Next
    Set objApp = Nothing
    Set recipients = Nothing
End Sub

 

[psrs0810]

Perfect - Thank you!