VBA Macro to send multiple unique emails to unique addresses

[monkeymaster]

Hi,

I am trying to create a VBA macro that will generate outlook emails based on unique information in the cells. Every email is different and is going to different people. I need it to be able to generate numerous emails at a time without having to rerun the script. My file is set up so that column A is the 'To:" column B is 'CC', column C is the subject, and column D is the email.

Does anyone have a VBA code that will loop through these cells and generate previews of the emails?

To​	CC​	Subject​	Email​
Hi@hi.com​	hi@hello.cm​	test​	another test​
M@M.com​	N@n.com​	test2​	another test 2​

 

[Eric W]

Welcome to the forum.

Check out this thread:

VBA Question - Can this be done easily?

I need some assistance please all. I have around 100 excel files that need to be emailed out every 2 days. I have just lost my admin resource and don't have time to do this manually. Is there a way, using a defined address book or list of email addresses to create a macro that matches the...

www.mrexcel.com

It should be easy enough to adapt that to get the subject and body from the spreadsheet. Change .Send to .Display to preview them before sending.

 

[monkeymaster]

So I have the code as below but can't figure out how to get the cc, subject, and body to update for each unique email within the rows.

Sub Mail_Workbooks()
Dim OutApp As Object, OutMail As Object, WS As Worksheet, r As Long


Set OutApp = CreateObject("Outlook.Application")

Set WS = Sheets("MACRO")
On Error Resume Next


For r = 2 To WS.Cells(Rows.Count, "A").End(xlUp).Row

With OutApp.CreateItem(0)
.To = WS.Cells(r, 1).Value
.CC = Range("B2")
.Subject = Range("c2")
.Body = Range("d2")
.Display
End With
DoEvents
Next r

On Error GoTo 0
Set OutApp = Nothing
End Sub

 

[Eric W]

This is untested, but should give you the idea:

Sub Mail_Workbooks()
Dim OutApp As Object, OutMail As Object, WS As Worksheet, r As Long


    Set OutApp = CreateObject("Outlook.Application")

    Set WS = Sheets("MACRO")
    On Error Resume Next

    For r = 2 To WS.Cells(Rows.Count, "A").End(xlUp).Row

        With OutApp.CreateItem(0)
            .To = WS.Cells(r, "A").Value
            .CC = WS.Cells(r, "B").Value
            .Subject = WS.Cells(r, "C").Value
            .Body = WS.Cells(r, "D").Value
            .Display
        End With
        DoEvents
    Next r

    On Error GoTo 0
    Set OutApp = Nothing
    
End Sub