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

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

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

###Excelファイル1シート目に送信側の情報
送信アドレス
件名
CC
BCC
本文
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/428253/292e4fc3-44af-f7f9-ea11-be68e74681eb.png)



###Excelファイル2シート目から取得した宛先情報
会社名
役職
メールアドレス
名前
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/428253/28cfad4e-3cf0-7421-94a9-f5299919913f.png)


#実際のコード


```vb: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
```

#解説
##フィルターをかけた場合の処理
フィルターがかかっている時は表示されている行のみをループして情報を取得しています。



```vb
    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列の企業名を基準として判定しています。


```vb
    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に代入します。


```vb

    R_Start = 2

```



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

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


```vb

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

```