VBA Send one auto email to Multiple Recipients

[nrah]

Hi, I want to send one email to multiple recipients, the code I have gives multiple emails with the same body and subject. How do I do it as here is my code


'Late Binding
Sub Send_Multiple_Email()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Sheet1")

Dim OA As Object
Dim msg As Object

'Create the Outlook application
Set OA = CreateObject("Outlook.Application")
Dim i As Integer
Dim last_row As Integer
'Dim mail_ids As String

last_row = Application.WorksheetFunction.CountA(sh.Range("A:A"))
Set msg = OA.createitem(0)



For i = 2 To last_row
Set msg = OA.createitem(0)


msg.To = sh.Range("A" & i).Value
msg.cc = sh.Range("B" & i).Value
msg.Subject = sh.Range("E" & i).Value
msg.body = sh.Range("G" & i).Value

'If sh.Range("E" & i).Value <> "" Then
'msg.attachments.Add sh.Range("E" & i).Value
'End If

msg.display

Next i

MsgBox "Mail Sent"


End Sub

 

[mrshl9898]

Not sure what to do about the cc, subject and body. But to send to the emails in A:

'Late Binding
Sub Send_Multiple_Email()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Sheet1")

Dim OA As Object
Dim msg As Object

'Create the Outlook application
Set OA = CreateObject("Outlook.Application")
Dim i As Integer
Dim last_row As Integer
'Dim mail_ids As String

last_row = Application.WorksheetFunction.CountA(sh.Range("A:A"))
Set msg = OA.createitem(0)




Set msg = OA.createitem(0)

For i = 2 To last_row
msg.To = msg.To & ";" & sh.Range("A" & i).Value
Next i
msg.cc = sh.Range("B" & i).Value
msg.Subject = sh.Range("E" & i).Value
msg.body = sh.Range("G" & i).Value

'If sh.Range("E" & i).Value <> "" Then
'msg.attachments.Add sh.Range("E" & i).Value
'End If

msg.display



MsgBox "Mail Sent"


End Sub

 

[nrah]

Not sure what to do about the cc, subject and body. But to send to the emails in A:

'Late Binding
Sub Send_Multiple_Email()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Sheet1")

Dim OA As Object
Dim msg As Object

'Create the Outlook application
Set OA = CreateObject("Outlook.Application")
Dim i As Integer
Dim last_row As Integer
'Dim mail_ids As String

last_row = Application.WorksheetFunction.CountA(sh.Range("A:A"))
Set msg = OA.createitem(0)




Set msg = OA.createitem(0)

For i = 2 To last_row
msg.To = msg.To & ";" & sh.Range("A" & i).Value
Next i
msg.cc = sh.Range("B" & i).Value
msg.Subject = sh.Range("E" & i).Value
msg.body = sh.Range("G" & i).Value

'If sh.Range("E" & i).Value <> "" Then
'msg.attachments.Add sh.Range("E" & i).Value
'End If

msg.display



MsgBox "Mail Sent"


End Sub

Thank YOU!!