複数の送信先に異なる本文のメールを一斉に送信する。

VBAでメール(Outlook)を複数の送信先に、それぞれ本文を編集して異なる本文のメールを一斉に送信するための処理です。

※VBAでOutlookのメールを作成、送信する処理自体は下記のリンクのページに記載しています。
　　メールの作成と送信（Outlook）
※サンプルコードでは誤って実行した時に誤送信しないようにSendメソッドをコメントアウトしています。その代わりDispalyメソッドで代用してメールの確認をするようにしています。

宛先などの設定はメール設定シートを作成し、その情報を元にメールを一斉に送信するようにしています。

設定シートについては下記の画像のように作成しています。
件名をB2セル、本文をB4セル（セル結合してます）に記載しています。
本文内で送信先ごとに内容を変えたい部分を＜＞で括り、その文字列の部分を置換させて本文を個々編集させています。
例文では<TO_NAME>、＜EVENTDAY＞、＜LOCATION＞の部分が置換対象となり、それぞれ設定シートのG～I列の内容に置換されるようにしています。

D列に送信先アドレス、E列とF列はCCとBCCの送信先を指定します。（複数ある場合は ; で区切る）
G列以降はそれぞれ本文に反映させたい内容を記載しています。

　●個々本文を編集して個別に送信

'設定シート
Const SHT_MAIL = "Mail"

'置換用文字列
Const REPSTR_RECEIVER = "<TO_NAME>"
Const REPSTR_EVENTDAY = "<EVENTDAY>"
Const REPSTR_LOCATION = "<LOCATION>"

'*********************************************************************
'　複数名に個々送信（シートの情報を元にメールの作成・送信）
'*********************************************************************
Sub sendMail_eachPerson()

    '件名・本文・送信者名取得
    Dim sSubject As String
    sSubject = Sheets(SHT_MAIL).Range("B2")

    Dim sBody As String
    sBody = Sheets(SHT_MAIL).Range("B4")


    '個々の編集・送信
    Dim i As Long
    Dim j As Long
    Dim sTo As String
    Dim sToName As String
    Dim sCc As String
    Dim sBcc As String
    Dim sLoc As String
    Dim sEvt As String
    Dim sBodyTemp As String
    
    For i = 2 To 10
        '宛先（To）が空行であればループを抜ける
        If Trim(Sheets(SHT_MAIL).Cells(i, 4)) = "" Then: Exit For
    
        'TO、CC、BCCなどを取得
        sTo = Sheets(SHT_MAIL).Cells(i, 4)
        sCc = Sheets(SHT_MAIL).Cells(i, 5)
        sBcc = Sheets(SHT_MAIL).Cells(i, 6)
        
        '本文反映内容の取得
        sToName = Sheets(SHT_MAIL).Cells(i, 7)
        sEvt = Sheets(SHT_MAIL).Cells(i, 8)
        sLoc = Sheets(SHT_MAIL).Cells(i, 9)
        
        '本文を個別に編集
        sBodyTemp = Replace(sBody, REPSTR_RECEIVER, sToName)   '置換１
        sBodyTemp = Replace(sBodyTemp, REPSTR_EVENTDAY, sEvt)  '置換２
        sBodyTemp = Replace(sBodyTemp, REPSTR_LOCATION, sLoc)  '置換３


        'メール作成、送信
        Call sendMail(sTo, sSubject, sBodyTemp, sCc, sBcc, 1, 2)

    Next
    
End Sub

'*********************************************************************
'　メール作成・送信
'*********************************************************************
Sub sendMail(mlTo As String, mlSubject As String, mlBody As String, _
             Optional mlCc As String, Optional mlBcc As String, _
             Optional mlFromat As Long = 1, _
             Optional mlImportance As Long = 1)

    'アプリケーションオブジェクト
    Dim oMailApp As Object
    Set oMailApp = CreateObject("Outlook.Application")
    
    'メール作成
    Dim oMail As Object
    Set oMail = oMailApp.CreateItem(0)
    
    '形式(1:テキスト型、2:HTML型、3:リッチテキスト型)
    oMail.BodyFormat = mlFromat
                
    '重要度(0:低、1:中（規定値）、2:高)
    oMail.Importance = mlImportance
                
    '宛先
    oMail.To = mlTo   'TO
    oMail.cc = mlCc    'CC
    oMail.bcc = mlBcc   'BCC
        
    '件名
    oMail.Subject = mlSubject
        
    '本文
    oMail.Body = mlBody
        
    '送信実行
    '※サンプルでは誤送信しないようにSendメソッドをコメントアウトし、
    '　Dispalyメソッドで代用しています｡
    ''oMail.Send
     oMail.Display  'メール表示 ※Sendの代わりに使用

    Set oMail = Nothing
    Set oMailApp = Nothing
    
End Sub

　■実行結果