Email Automation

1Option Explicit
2 
3' Email Automation — send personalised emails from a "Recipients" list
4' with per-row attachments and rate limiting.
5 
6Public Sub SendMailMerge()
7    Dim ws As Worksheet, i As Long, lastRow As Long
8    Dim OutApp As Object, OutMail As Object
9    Dim toAddr As String, subject As String, body As String
10 
11    On Error GoTo Fail
12    Set ws = ThisWorkbook.Worksheets("Recipients")
13    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
14 
15    Set OutApp = CreateObject("Outlook.Application")
16 
17    For i = 2 To lastRow
18        toAddr = CStr(ws.Cells(i, "A").Value)
19        subject = CStr(ws.Cells(i, "B").Value)
20        body = BuildBody(ws, i)
21 
22        Set OutMail = OutApp.CreateItem(0)
23        With OutMail
24            .To = toAddr
25            .Subject = subject
26            .HTMLBody = body
27            If Len(ws.Cells(i, "D").Value) > 0 Then .Attachments.Add CStr(ws.Cells(i, "D").Value)
28            .Send
29        End With
30 
31        ws.Cells(i, "E").Value = "Sent " & Now
32        Application.Wait Now + TimeSerial(0, 0, 2)  ' rate limit
33    Next i
34 
35    MsgBox lastRow - 1 & " emails sent.", vbInformation
36    Exit Sub
37Fail:
38    MsgBox "Mail merge failed: " & Err.Description, vbCritical
39End Sub