Excel VBAでoutlookのメールを作成する

はじめに

Excelに記入された情報を取得して、自動でoutlookのメールを作成するVBAを作成したのでメモとして残します。

内容

Excelファイルから送信側の情報・宛先情報を取得する。
宛先リストにフィルターをかけた場合は、表示されている宛先だけにメールを作成できるようにする。

Excelファイル1シート目に送信側の情報

送信アドレス
件名
CC
BCC
本文

Excelファイル2シート目から取得した宛先情報

会社名
役職
メールアドレス
名前

実際のコード

make_mail.xlsm

    Sub Sample()
        '変数定義
        Dim OL As Outlook.Application
        Dim MI As Outlook.MailItem
        Dim R_Start As Integer, R_End As Integer
        Dim Rownum As Integer
        Dim Str As String
        Dim LastRow As Long
        Str = "様"

        'outlookアプリを指定
        Set OL = CreateObject("Outlook.Application")

        'フィルターがかかっている場合の処理
        If ActiveSheet.FilterMode = True Then

            '表示されている行のみをループ
            With Range("C1").CurrentRegion.Offset(1, 0)
                For Each R In .Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Rows
                    Rownum = R.Row
                    Set MI = OL.CreateItem(olMailItem)


                    MI.SentOnBehalfOfName = Worksheets("data").Range("B2")    '差出人
                    MI.Subject = Worksheets("data").Range("B3")    '件名
                    MI.To = Cells(Rownum, 6)    'To
                    MI.Cc = Worksheets("data").Range("B4")  'CC
                    MI.Bcc = Worksheets("data").Range("B5")    'BCC

                '本文
                  MI.Body = Cells(Rownum, 3) & vbCr _
                      & Cells(Rownum, 5) & Str & vbCr _
                      & Worksheets("data").Range("B6") & vbCr _



                  MI.Save
                'MI.Display    'メール表示
                Next R
            End With
            'メールのオブジェクトをリセット
            Set OL = Nothing
            Set MI = Nothing

            MsgBox "完了"

        'フィルターがかかっていない場合の処理
        Else
            R_Start = 2
            LastRow = Cells(Rows.Count, 3).End(xlUp).Row


            For R_Start = R_Start To LastRow

                Rownum = R_Start
                Set MI = OL.CreateItem(olMailItem)


                MI.SentOnBehalfOfName = Worksheets("data").Range("B2")    '差出人
                MI.Subject = Worksheets("data").Range("B3")    '件名
                MI.To = Cells(Rownum, 6)    'To
                MI.Cc = Worksheets("data").Range("B4")  'CC
                MI.Bcc = Worksheets("data").Range("B5")    'BCC


            '本文

              MI.Body = Cells(Rownum, 3) & vbCr _
                  & Cells(Rownum, 5) & Str & vbCr _
                  & Worksheets("data").Range("B6") & vbCr _

              MI.Save
            'MI.Display    'メール表示
            Next R_Start

        Set OL = Nothing
        Set MI = Nothing

        MsgBox "完了"

        End If

    End Sub

解説

フィルターをかけた場合の処理

フィルターがかかっている時は表示されている行のみをループして情報を取得しています。

    If ActiveSheet.FilterMode = True Then

            '表示されている行のみをループ
            With Range("C1").CurrentRegion.Offset(1, 0)
                For Each R In .Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Rows
                    Rownum = R.Row

templateシートC列の企業名を基準として判定しています。

    With Range("C1").CurrentRegion.Offset(1, 0)

.Resize(.Rows.Count - 1)　　　　　　  基準としているC1セルから一つ下がった行からのループ

SpecialCells(xlCellTypeVisible).Rowsで表示されている行を取得しています



    For Each R In .Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Rows

フィルターがかかっていない場合の処理

ループの先頭行をR_Startに代入します。

    R_Start = 2

ループの最終行をLastRowに代入します。

基準とする列を指定して、End(xlUp).Rowで最終行を取得しています。

    LastRow = Cells(Rows.Count, 3).End(xlUp).Row