Thread: Send outlook emails with message in cells to individual emails associated with them

Hi everyone,

Basically I have a data sheet with a list individuals in one column and individual messages in the next and their associated email addresses in another. I have an excel VBA code which sends the whole worksheet as an email attachment to a specific address. Is there a way to modify the code to send individual emails with individual messages via outlook?

I would basically like the macro to run through each ID and select and copy the data range associated to it as the body of the message and then send it to the corresponding email address. The datarange varies for each ID and I have more than a 1000 of them. I have attached an example sheet with this.

The code I have currently which sends the whole worksheet as an attachment is as follows:
Sub email()
Dim myOutlook As Object
Dim myMailItem As Object
Dim FName As String
Set otlApp = CreateObject("Outlook.Application")
Set otlNewMail = otlApp.CreateItem(olMailItem)
FName = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
With otlNewMail
.To = "xxx@yyy.com"
.CC = ""
.Subject = "Test"
.Body = "Test"
.Attachments.Add FName
.DeferredDeliveryTime = Range("A1")
.Send
End With

Set otlNewMail = Nothing
Set otlApp = Nothing
Set otlAttach = Nothing
Set otlMess = Nothing
Set otlNSpace = Nothing
End Sub




Thanks guys.

Sub email()
Dim myOutlook As Object
Dim myMailItem As Object
Dim FName As String
Set otlApp = CreateObject("Outlook.Application")
Set otlNewMail = otlApp.CreateItem(olMailItem)
FName = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
With otlNewMail
.To = "xxx@yyy.com"
.CC = ""
.Subject = "Test"
.Body = "Test"
.Attachments.Add FName
.DeferredDeliveryTime = Range("A1")
.Send
End With

Set otlNewMail = Nothing
Set otlApp = Nothing
Set otlAttach = Nothing
Set otlMess = Nothing
Set otlNSpace = Nothing
End Sub

Hi Everyone,

Just wondering if anyone can help me with this problem. Your help will be greatly appreciated.

Thanks..