Collate data in rows based on same email address?

Question

I am working to automate my email outflow using Excel VBA.

I have A, B, C columns in Excel.
Column A contains the content the name of addressee (one addressee can show up multiple times).
Column B contains the email address I want to send the content.
Column C contains the content, I want in the email (these are always unique even if column A is not unique for the lines).

I can write code to loop through the lines and send the emails one by one.

Sub CreateCourseCertificates()
    
    Dim EApp As Object
    Set EApp = CreateObject("Outlook.Application")
    Dim EItem As Object
    
    Dim RList As Range
    Set RList = Range("A1", Range("a1").End(xlDown))
    
    Dim R As Range
    
    For Each R In RList
        Set EItem = EApp.CreateItem(0)
        With EItem
            .To = R.Offset(0, 0)
            .Subject = "Subject"
    
            .Body = "Dear "
            .Send
        
        End With
    Next R
    
    Set EApp = Nothing
    Set EItem = Nothing
    
End Sub

My aim is to loop through the lines, but send the all the content in one email.

To demonstrate:

A:             B:                   C:
Facebook.com   [email protected]   NUMBER 3532  
Instgram.com   [email protected]   Please refer  
Instgram.com   [email protected]   Please include 242 
Netflix.com    [email protected]   I will send   
Netflix.com    [email protected]   Include Number 214

I would like to automate the outbound email like:

First email:

to = [email protected]  
content = Facebook.com & NUMBER 3532

Second email:

to = [email protected]  
content =  
Instgram.com & Please refer  
Instgram.com & Please include 242

Third email:

to = [email protected]  
content =  
Netflix.com & I will send
Netflix.com & Include Number 214

and repeat until A column last cell value is not blank.

I have been thinking of do while within my for each, but I couldn't make it work.

Answer 1

When you loop the range, collect the emails into a Dictionary keyed on To, and append the body text into each Item.

Then loop the dictionary, sending the emails

Something like:

Sub CreateCourseCertificates()
    Dim EApp As Object
    Set EApp = CreateObject("Outlook.Application")
    Dim EItem As Object
    Dim RList As Range
    Dim dic As Object
    Dim bodytext As Variant
    Set RList = Range("A1", Range("a1").End(xlDown))
    
    Set dic = CreateObject("Scripting.dictionary")
    Dim R As Range
    EApp.Quit
    For Each R In RList
        If dic.Exists(R.Offset(0, 0).Value2) Then
            bodytext = dic(R.Offset(0, 0).Value2)
            bodytext = bodytext & vbNewLine & R.Offset(0, 1).Value2 & " " & R.Offset(0, 2).Value2
            dic(R.Offset(0, 0).Value2) = bodytext
        Else
            dic.Add R.Offset(0, 0).Value2, R.Offset(0, 1).Value2 & " " & R.Offset(0, 2).Value2
        End If
    Next
    
    Dim email As Variant
    For Each email In dic
        ' Send to email , boby text dic(email)
        ' Add any other text here, eg greeting and signature
        Debug.Print email
        Debug.Print dic(email)
        Debug.Print
    Next
    
End Sub