【エクセルVBA】エクセルシートに一覧化された複数の連絡先に本文を変えつつOutlookでメールを一括送信する方法

みなさまこんにちは、ノグチです。

前回は、エクセルVBAからOutlookを操作して、エクセルシートに記入された内容を、メールの件名と本文にセットして、Outlookからメールを送信させる方法をご紹介しました。

エクセルシートに記入された件名や本文を、エクセルVBAによってOutlookのメールの件名と本文にセットしてメール送信する方法をご紹介しています。VBAでメールの送信ができれば、宛先に応じてメールの本文を変えつつ一斉に送信することもできますよ。

仕事の取引先にメールをする際、メールの冒頭には相手の会社名、部署名、担当者名を入れたりしますよね。

ビジネスメールのマナーとはいえ、1件、２件ならまだしも、10件、20件となってくると中々苦痛な作業です。

コピー＆ペーストしたとしても、会社名や名前を間違ってコピペしてしまっていたらもう最悪です。

ミスの防止と手間削減のために、それ、エクセルVBAで自動化してしまいましょう！

今回は、前回ご紹介したエクセルVBAでメールを送信するコードにFor~Nextを加えて、エクセルシートに一覧化された複数のメールアドレスに、メール本文を変えつつメールを一括送信する方法をご紹介します！

エクセルシートに一覧化された送信先に一括でメールを送りたい
本文を変えつつ複数メールアドレスにメールを一括送信するコード
1. CreateItemメソッドの場所に注意
上のコードで作成されたメール
最後に
連載目次：エクセルVBAでOutlookを操作してみよう！

エクセルシートに一覧化された送信先に一括でメールを送りたい

例えば、こちらのリスト。

リストのD列にあるメールアドレスに、メールの本文にA列の会社名、B列の部署名、C列の担当者名を盛り込みつつ、メールを送信したいとします。

メール本文のテンプレートがこちらのシート。

B2セルにあるメール本文の冒頭に送信先シートにある会社名、部署名、担当者名を追加しつつ、メールを送っていきます。

本文を変えつつ複数メールアドレスにメールを一括送信するコード

上の送信先シートの送信先に、メール内容シートの本文と送信先シートの情報を結合させてメール送信するコードがこちら。

何も難しいことはありません。

前回の記事でご紹介したコードのCreateItemメソッドでMailItemオブジェクトを作成する部分からSendメソッドでメール送信する部分をFor~Next文で挟んで、With文とメール本文を加工するステップを修正しただけという、結構単純なコードです。

(CreateItemメソッドとMailItemオブジェクトについては、前回記事をご覧ください。)

Sub SendEmail()

Dim objOutlook As Outlook.Application
Dim i
Dim rowMax As Long
Dim wsList As Worksheet
Dim wsMail As Worksheet
Dim objMail As Outlook.MailItem

Set objOutlook = New Outlook.Application
Set wsList = ThisWorkbook.Sheets("送信先")
Set wsMail = ThisWorkbook.Sheets("メール内容")

With wsList

    '送信先の件数
    rowMax = .Cells(Rows.Count, 1).End(xlUp).Row

    '送信先の件数分繰り返す
    For i = 2 To rowMax
        Set objMail = objOutlook.CreateItem(olMailItem)
        With wsMail
            .To = wsList.Cells(i, 4).Value       'メール宛先
            .Subject = .Range("B1").Value        'メール件名
            .BodyFormat = olFormatPlain          'メールの形式
            .Body = wsList.Cells(i, 1).Value & vbCrLf & _
                         wsList.Cells(i, 2).Value & " " & _
                         wsList.Cells(i, 3).Value & " 様" & vbCrLf & vbCrLf & _
                        .Range("B2").Value              'メール本文
    
           objMail.Send
        End With
    Next i

    Set objOutlook = Nothing
    MsgBox "送信完了"

End With

End Sub