エクセルVBA×Outlook｜複数の宛先毎に添付ファイル付きメールを作成する

複数の宛先毎に添付ファイル付きメールを作成する

先にポイントを提示しておきます。以下3点です。

一括管理できる様に出来上がったメールは下書きフォルダに格納する事にします。

関連書籍

ExcelVBAからOutlookを操作してメールを用意するという一連の流れは一般の書籍でも紹介されています。

Outlookについて

冒頭で紹介したシリーズ1番目の記事内でOutlookについて解説しています。

基本編エクセルVBA×Outlook｜メールにハイパーリンク&添付ファイルを用意する

応用編：複数の宛先毎に添付ファイル付きメールを作成する

実際の作業に移ります。まずは作業内容の確認です。冒頭でも紹介した様に以下3つを実現させます。

事例を用意しました

手作業で考えると数時間かかる作業です。VBAなら30秒もかかりませんよ。

アウトプット

まずは動画（30秒程度）をご確認ください。以降の説明が理解しやすくなる為です。

出来上がったメールには会社名と担当者様宛の文字が用意されます。加えて添付ファイルにも取引先の名前が入ります。

添付ファイルの中は以下画像の様になっています。取引先にかかわる品番などの情報が用意されています。

作業環境（フォルダやワークブック、シートなど）

1_5_7 各種フォルダ

主にデータをまとめる為の役割をしています。

• 1_フォルダ（Outlook応用編）・・・データ全体を収納するフォルダです。
• 5_フォルダ（テンプレート）・・・テンプレートとして使用するデータを収納するフォルダです。
• 7_フォルダ（取引先ごとのファイル）・・・取引先ごとに用意する添付データを格納するためのフォルダです。

2_メール準備.xlsm

このエクセルファイルにマクロを用意しています。ワークシートにはマクロのトリガーとなるボタンを用意しています。

3_品番.xlsx

ワークシートは1枚です。ワークシート名は「品番」です。

4_取引先.xlsx

ワークシートは1枚です。ワークシート名は「取引先」です。

6_調査票テンプレート.xlsx

8_取引先ごとに用意することになる.xlsxファイル

ファイル名は「1000100_有限会社オカモト.xlsx」という名前が付けられます。その後⑧のフォルダに格納されます。

9_メールテンプレート.oft

10_Outlook下書きフォルダ

コード

コードはこちらです。コードの量が多いのでウインドウを2つに分けました。

'****************************************************************
Sub 添付データを作成してメールに添付()

Dim sup As Variant 'supplier
Dim num As Variant 'number
Dim frow As Long 'finalrow
Dim fclm As Long 'finalcolumn
Dim wb1 As Workbook '取引先
Dim wb2 As Workbook '品番

Application.ScreenUpdating = False

Call datasetting(sup, num, frow, fclm, wb1, wb2)
Call datapreparation(sup, num, fclm)

Application.ScreenUpdating = True

MsgBox "作業完了"

End Sub
'****************************************************************
Sub datasetting(ByRef sp As Variant, ByRef nm As Variant, ByVal frw As Long, ByVal fcm As Long, ByVal w1 As Workbook, ByVal w2 As Workbook)

'必要なデータを揃える
Set w1 = Workbooks.Open(ThisWorkbook.Path & "\取引先.xlsx")
frw = r(w1.Sheets("取引先"), 1)
fcm = c(w1.Sheets("取引先"), 1)
With w1.Sheets("取引先")
    sp = .Range(.Cells(1, 1), .Cells(frw, fcm))
End With
w1.Close

Set w2 = Workbooks.Open(ThisWorkbook.Path & "\品番.xlsx")
frw = r(w2.Sheets("品番"), 1)
fcm = c(w2.Sheets("品番"), 1)
With w2.Sheets("品番")
    nm = .Range(.Cells(1, 1), .Cells(frw, fcm))
End With
w2.Close

End Sub
'****************************************************************
Function r(sht, rw)
'最終行を取得する為の関数
    r = sht.Cells(Rows.Count, rw).End(xlUp).row
End Function
'****************************************************************
Function c(sht, cm)
'最終列を取得する為の関数
    c = sht.Cells(cm, Columns.Count).End(xlToLeft).Column
End Function
'****************************************************************

続いて残り2つのプロシージャです。

'****************************************************************
Sub datapreparation(ByRef sp As Variant, ByRef nm As Variant, ByVal frw As Long)
'仕入先＆品番データを使って調査票を作る

Dim sch1 As Long 'serch1
Dim sch2 As Long 'serch2
Dim pth As String 'filepath　ファイルパス
Dim fname As String 'filename ファイルネーム
Dim wb3 As Workbook '調査票
Dim cpy As String 'company　会社名
Dim name As String 'name　担当者名
Dim ead As String 'emailaddress　メルアド

Workbooks.Open (ThisWorkbook.Path & "\テンプレート\調査票テンプレート.xlsx")
Set wb3 = Workbooks("調査票テンプレート.xlsx")

ReDim tem(1 To 4, 1 To 1) As Variant 'temporary
Dim snum As Long: snum = 1 'serialnumber

For sch1 = LBound(sp) + 1 To UBound(sp)
    For sch2 = LBound(nm) + 1 To UBound(nm)
        If sp(sch1, 1) = nm(sch2, 3) Then
            tem(1, snum) = nm(sch2, 1)
            tem(2, snum) = nm(sch2, 2)
            tem(3, snum) = nm(sch2, 3)
            tem(4, snum) = nm(sch2, 4)
            snum = snum + 1
            ReDim Preserve tem(1 To 4, 1 To snum)
        End If
    Next
    ReDim Preserve tem(1 To 4, 1 To snum - 1)

    With wb3.Sheets("調査依頼")
        .Range(.Cells(6, 2), .Cells(UBound(tem, 2) + 5, 5)) = WorksheetFunction.Transpose(tem)
        
        '最終行を認識（罫線を書く為）
        frw = r(wb3.Sheets("調査依頼"), 2)
        
        '必要箇所にまずは黒の罫線を一通り書く
        With .Range(.Cells(6, 2), .Cells(frw, 5))
            .Borders.LineStyle = xlContinuous
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
        
        Columns("A:E").AutoFit
        pth = ThisWorkbook.Path & "\取引先ごとのファイル"
        fname = "\" & sp(sch1, 3)
        wb3.SaveCopyAs Filename:=ThisWorkbook.Path & "\取引先ごとのファイル" & fname
        
         .Range(.Cells(6, 2), .Cells(UBound(tem, 2) + 5, 5)).Clear
    End With

    snum = 1
    ReDim tem(1 To 4, 1 To snum)
    cpy = sp(sch1, 2)
    name = sp(sch1, 4)
    ead = sp(sch1, 5)
    Call attachedfile(fname, cpy, name, ead)
  
Next

Application.DisplayAlerts = False
wb3.Close
Application.DisplayAlerts = True

End Sub
'****************************************************************
Sub attachedfile(ByVal fnm As String, ByVal cy As String, ByVal nm As String, ByVal ea As String)
'datapreparationで作ったデータをメールに添付してOutlookの下書きに格納する

Dim Olk As Outlook.Application
Dim Mail As Mailitem
Dim Amt As Attachments
Dim a As String
Dim b As String
Dim c As String

Set Olk = CreateObject("Outlook.Application")
Set Mail = Olk.CreateItemFromTemplate(ThisWorkbook.Path & "\テンプレート\メールテンプレート.oft")
Set Amt = Mail.Attachments

With Mail
    .To = ea     'メール宛先
    .Subject = "ご確認ください" 'メール件名
    .BodyFormat = 2    'メールの形式
    
    a = .HTMLBody 'テンプレートの内容を格納
    b = "<span style=""font-size:11pt"";""font-family:游ゴシック"">" '書式設定
    c = cy & " " & nm & "様"
    'a、b、cを合わせる
    .HTMLBody = b & c & a
End With

Amt.Add ThisWorkbook.Path & "\取引先ごとのファイル" & fnm
Mail.Save
End Sub
'****************************************************************

解説

SubプロシージャとFunctionプロシージャ合わせて6つあります。プロシージャごとに解説します。

添付データを作成してメールに添付

ポイントはサブルーチンですね。Callメソッドを使って別のプロシージャを呼び出しています。

関連記事【マトリクスで理解する】プロシージャを分割したマクロを用意する方法

datasetting

関連記事【応用編】ExcelVBAでピボットテーブルと連動したグラフを自動で作成する

r

最終行を返す関数として用意しています。

c

最終列を返す関数として用意しています。

datapreparation

ここでのポイントは2次元配列とファイルパスです。

関連記事【検索にも使える】VBAの2次元配列で作業の高速化を実現させる

関連記事【VBA】絶対パス相対パスの書き方｜理解はカレントディレクトリがポイント

attachedfile

このプロシージャを理解するには前回記事を見ていただくことをおすすめします。

関連記事エクセルVBA×Outlook｜メールにハイパーリンク&添付ファイルを用意する

まとめ

参考：実務で使う際はもう少し工夫が必要です

EnjoyExcel