I'm new on stackoverflow, I'm a beginner on VBA and I want to simplify a task that I do regularly. I have a list of mail in column B to which I have to send attachments in columns D and E. These mails can be redundant, so I should not create several mails for the same person, hence the column A with the ID number.

Would you know how to generate X mails (X = max ID of column A) with all the attachments?

Thank you very much in advance

Sub create_multiple_emails()
    Dim c As Range, sh As Worksheet, ky As Variant, m As Range, sBody As String
    Dim Temp As Integer
    Dim dam As Object, dict As Object
    Dim PJ As Variant
    
    
    Set sh = Sheets("Base")
    Set dict = CreateObject("scripting.dictionary")
    
    Temp = 2
    
    For Each c In sh.Range("J2", sh.Range("J" & Rows.Count).End(xlUp))
        
        If Not dict.Exists(c.Value) Then
            dict(c.Value) = dict(c.Value)
            sBody = "Userids - Locations" & vbCr
            sh.Range("J1").AutoFilter 1, c
            For Each m In sh.Range("D2", sh.Range("D" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
                sBody = sBody & m.Value & " - " & m.Offset(, 1).Value & vbCr
            Next
              
            Set dam = CreateObject("Outlook.Application").CreateItem(0)
            dam.To = c
            dam.Subject = "Subject"
            dam.body = sBody
            'dam.Send 'to send
            dam.display 'to show
        End If
        
        Temp = Temp   1
        
    Next
    sh.ShowAllData
End Sub

CodePudding user response：

I think you're on the right track using a Dictionary. Here is an example that you must adapt to your solution. It builds up a dictionary of the email recipients (doesn't need the ID column) and creates a list of all the attachments for each recipient.

Option Explicit

Sub CreateEmails()
    Dim recipients As Dictionary
    Set recipients = AllEmailsAndAttachments

    Dim emailApp As Outlook.Application
    Set emailApp = AttachToOutlookApplication
    If emailApp Is Nothing Then
        MsgBox "Where is Outlook?!?:"
        Exit Sub
    End If
    
    Dim recipient As Variant
    For Each recipient In recipients.Keys
        '--- the "Item" in the dictionary is the CC recipient followed
        '    by the list of attachments
        Dim items As Variant
        items = Split(recipients(recipient), ",")
        
        '--- create the email
        Dim thisEmail As Outlook.MailItem
        Set thisEmail = emailApp.CreateItem(olMailItem)
        With thisEmail
            .To = recipient
            .CC = items(0)   'CC is always the first item in the list
            .Subject = "Important Attachments"
            
            '--- put the list of attachments in the body, but remember
            '    to delete the first line (which is the CC recipient)
            Dim emailBody As String
            emailBody = Join(items, vbCr)
            emailBody = Right$(emailBody, Len(emailBody) - InStr(1, emailBody, vbCr))
            emailBody = "Userids - Locations" & vbCr & emailBody
            .Body = emailBody
            
            Dim i As Long
            For i = 1 To UBound(items)
                '--- assumes each item is a full pathname to the file
                '.Attachments.Add items(i)
            Next i
            .Display
            '.Send
        End With
    Next recipient
End Sub

Function AllEmailsAndAttachments() As Dictionary
    Dim baseWS As Worksheet
    Set baseWS = ThisWorkbook.Worksheets("Base")
    With baseWS
        Dim lastRow As Long
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        
        Dim recipients As Dictionary
        Set recipients = New Dictionary
    
        Const TO_COL As Long = 2
        Const CC_COL As Long = 3
        Const ATT1_COL As Long = 4
        Const ATT2_COL As Long = 5
        
        Dim i As Long
        Dim attachments As String
        For i = 2 To lastRow
            If Not recipients.Exists(.Cells(i, TO_COL).Value) Then
                attachments = .Cells(i, CC_COL).Value & "," & _
                              .Cells(i, ATT1_COL).Value & "," & _
                              .Cells(i, ATT2_COL).Value
                recipients.Add .Cells(i, TO_COL).Value, attachments
            Else
                Dim existingAttachments As String
                existingAttachments = recipients(.Cells(i, TO_COL).Value)
                attachments = existingAttachments & "," & .Cells(i, ATT1_COL).Value & _
                                                    "," & .Cells(i, ATT2_COL).Value
                recipients(.Cells(i, TO_COL).Value) = attachments
            End If
        Next i
    End With
    Set AllEmailsAndAttachments = recipients
End Function

Public Function AttachToOutlookApplication() As Outlook.Application
    '--- finds an existing and running instance of MS Outlook, or starts
    '    the application if one is not already running
    Dim msApp As Outlook.Application
    On Error Resume Next
    Set msApp = GetObject(, "Outlook.Application")
    If Err > 0 Then
        '--- we have to start one
        '    an exception will be raised if the application is not installed
        Set msApp = CreateObject("Outlook.Application")
    End If
    Set AttachToOutlookApplication = msApp
End Function

If you need the file file path to each attachment, look at this answer for some help.