Attribute VB_Name = "OutlookMailMerge"
Option Explicit

' Outlook mail merge from Excel
' Free module from sourabsaha.com
'
' Sheet "Mailing", headers in row 1:
'   A Name | B Email | C Subject | D Message | E Attachment path (optional) | F Status
' Write {Name} anywhere in the message to insert the person's name.
' Keep SendNow = False to review drafts first, then set it to True.

Private Const SendNow As Boolean = False

Public Sub SendMailMerge()
    Dim ws As Worksheet
    Dim olApp As Object, olMail As Object
    Dim lastRow As Long, r As Long, done As Long
    Dim attachPath As String

    Set ws = ThisWorkbook.Worksheets("Mailing")
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    If lastRow < 2 Then
        MsgBox "Add at least one email address in column B.", vbExclamation
        Exit Sub
    End If

    Set olApp = CreateObject("Outlook.Application")

    For r = 2 To lastRow
        If Len(ws.Cells(r, "B").Value) > 0 And ws.Cells(r, "F").Value <> "Sent" Then
            Set olMail = olApp.CreateItem(0)
            With olMail
                .To = ws.Cells(r, "B").Value
                .Subject = ws.Cells(r, "C").Value
                .Body = Replace(ws.Cells(r, "D").Value, "{Name}", ws.Cells(r, "A").Value)
                attachPath = Trim$(ws.Cells(r, "E").Value)
                If Len(attachPath) > 0 Then
                    If Len(Dir(attachPath)) > 0 Then .Attachments.Add attachPath
                End If
                If SendNow Then .Send Else .Display
            End With
            ws.Cells(r, "F").Value = IIf(SendNow, "Sent", "Draft opened")
            done = done + 1
            Set olMail = Nothing
        End If
    Next r

    Set olApp = Nothing
    MsgBox done & " email(s) processed.", vbInformation
End Sub