ExcelマクロでOutlookの送信相手ごとに本文を変更する方法(合否通知送付サンプル有)

Excel /VBA IT

こんにちは、副業エンジニアのてつをです。今回は、前回の続編ということで、Excelマクロで送信相手ごとに本文を変更する方法をご紹介します。前回作成したExcelマクロを改良して作成するので、前回の記事をご覧になられてない方はまずこちら(【最新】ExcelマクロでOutlookのメールを送信者指定して送信する方法)をご覧ください。もちろん、今回もコードをコピーしたらそのまま利用できるような形でご紹介させていただきます。
では早速、本題に入っていきましょう。

目次

  1. 【変更箇所①】送信者リストに合格・不合格を識別する列を追加する

  2. 【変更箇所②】合格者用の本文と不合格者用の本文を作成する

  3. Excel【変更箇所③】合格者・不合格者で利用する本文が変わるようVBAのコードを修正する

1.【変更箇所①】送信者リストに合格・不合格を識別する列を追加する

まず初めに、送信者リストに載っている一人一人に対して、合格か不合格かを判断できるようリストシートに「合否」列を追加します。後々、この「合否」列を見て合格者には合格通知を、不合格者には不合格通知を送れるようにします。

では、具体的に修正する箇所を確認していきます。
リストシートを開き、K列に「合否」列を追加します。また、それぞれの人に対して、「合格」か「不合格」を入力します。以下の図のように記載できていれば問題ないです。

2.【変更箇所②】合格者用の本文と不合格者用の本文を作成する

続いて、合格者・不合格者に対して送付するメールの本文を作成します。方法としては、メールシートに合格者向けの本文を不合格者向けの本文の2つを準備します。
では、具体的に修正する箇所を確認していきます。メールシートのB3セルには既にメール本文のサンプルがあったかと思うので、こちらを合格者向けの本文に書き替えます。一方、不合格者用のメール本文も必要であるため、C2セルに不合格者用の本文も作成します。最後に、タイトルも今回の例題に合わせて試験結果送付と変更すればOKです。サンプルとして、修正後のメールシートを以下に示します。

3.【変更箇所③】合格者・不合格者で利用する本文が変わるようVBAのコードを修正する

いよいよ最後の作業です。メール本文が合格者・不合格者で切り替わるようにVBAのコードを書き換えていきます。書き換える場所は、なんとたったの1か所です。
具体的に、修正する場所を確認していきます。まず、以下の記載を探してみてください。

この1行を以下の様に変更してください。

なんと、作業は以上です!
念のため書き換えたコードの説明をしておくと、新たに作成していただいた合否列に”合格”と記載されている人にはメール本文「B3」を使用し、それ以外の人(不合格の人)にはメール本文「C3」を利用するようになっています。
参考までに、サンプルとして全コードも掲載しておきます。


Sub Savebatchmail()

'---コード1|定義
    Dim toaddress, ccaddress, bccaddress As String  '変数設定:To宛先、cc宛先、bcc宛先
    Dim subject, mailBody, credit As String '変数設定:件名、メール本文、クレジット、添付
    Dim outlookObj As Object   'Outlookで使用するオブジェクト生成
    Dim mailItemObj As Object      'Outlookで使用するオブジェクト生成
    Dim olkApp
    Dim acctToSend
    SEND_ACCOUNT = Worksheets("メール").Range("B1")
    Dim MaxRow: MaxRow = Worksheets("リスト").Range("E2").End(xlDown).Row
    Dim wsMail As Worksheet
    Set wsMail = ThisWorkbook.Sheets("メール")
    Dim wsList As Worksheet
    Set wsList = ThisWorkbook.Sheets("リスト")
    
'---コード2|差出人、本文、署名を取得する---
    Dim I As Integer
    Dim j As Integer
    'Dim title As Range
    Dim step1 As String
    For I = 2 To MaxRow
        If wsList.Cells(I, 1) <> "NG" And wsList.Cells(I, 1) <> "済" Then
                    toaddress = wsList.Cells(I, 5).Value   'To宛先
                    'ccaddress = Range("B3").Value   'cc宛先
                    'bccaddress = Range("B4").Value  'bcc宛先
                    subject = wsMail.Range("B2").Value     '件名
                    
                    If wsList.Cells(I, 11).Value = "合格" Then 'メール本文
                        mailBody = wsMail.Range("B3").Value    '合格の場合
                    Else
                        mailBody = wsMail.Range("C3").Value    '不合格の場合
                    End If
                    
                    mailBody = Replace(mailBody, "■■", wsList.Cells(I, 4).Value) '会社名
                    mailBody = Replace(mailBody, "○○", wsList.Cells(I, 3).Value) '氏名
                    credit = wsMail.Range("B4").Value      '著名
            
            '---コード3|メールを作成して、差出人、本文、署名を入れ込む---
                    Set outlookObj = CreateObject("Outlook.Application")
                    Set mailItemObj = outlookObj.CreateItem(olMailItem)
                        ' Outlook のオブジェクトを取得
                    Set olkApp = CreateObject("Outlook.Application")
                    Set acctToSend = olkApp.Session.Accounts.Item(SEND_ACCOUNT)
                    Set mailItemObj.SendUsingAccount = acctToSend '差出人をセット
                    
                            mailItemObj.BodyFormat = 3      'リッチテキストに変更
                            mailItemObj.To = toaddress      'to宛先をセット
                            'mailItemObj.CC = ccaddress      'cc宛先をセット
                            'mailItemObj.BCC = bccaddress    'bcc宛先をセット
                            mailItemObj.subject = subject   '件名をセット
                    
                '---コード4|メール本文を改行する
                            mailItemObj.Body = mailBody '& vbCrLf & vbCrLf & credit   'メール本文 改行 改行 クレジット
                    
                
            '---コード5|自動で添付ファイルを付ける---
                    'Dim attached As String
                    'Dim myattachments As Outlook.Attachments 'Outlookで使用するオブジェクト生成
                    'Set myattachments = mailItemObj.Attachments
                    'attached = Range("B6").Value     '添付ファイル
                    'myattachments.Add attached
            
            '---コード6|メールを送信する---
                    mailItemObj.Save   '下書き保存
                    'mailItemObj.Display  'メール表示(ここでは誤送信を防ぐために表示だけにして、メール送信はしない)
                    wsList.Cells(I, 1) = "済"  'メールを作成したら、1行目に済を入れる
        End If
    Next I
'---コード7|outlookを閉じる(オブジェクトの解放)---
    Set outlookObj = Nothing
    Set mailItemObj = Nothing
    Set olkApp = Nothing
    Set acctToSend = Nothing

End Sub


Sub Which_Account_Number()
'Don't forget to set a reference to Outlook in the VBA editor
    Dim OutApp As Outlook.Application
    Dim I As Long

    Set OutApp = CreateObject("Outlook.Application")

    For I = 1 To OutApp.Session.Accounts.Count
        MsgBox OutApp.Session.Accounts.Item(I) & " : This is account number " & I
    Next I
End Sub



Public Sub SendUsingAccountFromExcel()
    Const SEND_ACCOUNT = "geodict-support@ml.scsk.jp"
    Const SEND_TO_ADDRESS = "fukushige@scsk.jp"
    Const MAIL_SUBJECT = "テスト メッセージ"
    Const MAIL_BODY = "Excel から送信しました。"
    Dim olkApp
    Dim objItem
    Dim acctToSend
    ' Outlook のオブジェクトを取得
    Set olkApp = CreateObject("Outlook.Application")
    ' メールアイテムを作成
    Set objItem = olkApp.CreateItem(0)
    ' 宛先、件名、本文を指定
    objItem.To = SEND_TO_ADDRESS
    objItem.subject = MAIL_SUBJECT
    objItem.Body = MAIL_BODY
    ' 送信アカウントを取得
    Set acctToSend = olkApp.Session.Accounts.Item(SEND_ACCOUNT)
    ' 送信アカウントを指定
    Set objItem.SendUsingAccount = acctToSend
    ' メールを送信
    objItem.Send
End Sub


修正箇所は以上となるので、試しにメール作成ボタンを押してみてください。下書きに、以下の様に合格者に対しては合格通知を、不合格者に対しては不合格通知がちゃんと作成できていますでしょうか。

本記事は以上となります。
今後、様々なパターンを記事にまとめていこうと考えておりますので、このような記事も書いてほしいなどありましたら是非お問い合わせください。
宜しくお願い致します。

以上。