Excel VBA Macro: Send Multiple Emails (with Multiple Attachments)

Excel VBA Macro: Send Multiple Emails (with Multiple Attachments)

Code (YouTube doesn't allow brackets; so LT and GT are used for less than and greater than, respectively):


Sub multi_emails_attachments()

Dim OutApp As Object
Dim OutMail As Object
Dim ws As Worksheet
Dim strbody As String
Dim row_count As Integer
Dim col_count As Integer
Dim i As Integer
Dim j As Integer

Set ws = ThisWorkbook.Sheets("Emails")

ws.Activate
row_count = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlDown)))
col_count = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlToRight)))

For i = 2 To row_count

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

strbody = "LT BODY style = font-size:12pt, font-familt:Arial GT" & _
"Hi Team, LT p GT Please see file(s) attached. LT p GT" & _
"Thanks, LT br GT Greg"

On Error Resume Next
With OutMail
.to = ws.Cells(i, 1).Text
.CC = ""
.BCC = ""
.Subject = ws.Cells(i, 2).Text
.Display
.HTMLBody = strbody & .HTMLBody

For j = 3 To col_count
.attachments.Add ws.Cells(i, j).Text
Next j

End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing

Next i

End Sub

#excelvba #excelmacro