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