投稿日: 投稿者: Excel Demon

【Excel】請求書メールを自動作成

取引先毎に請求書メールを作成するのは大変です。

テンプレート文さえ作れば宛先や添付するファイルを自動判定し、メール作成してくれるExcelファイルを作ってみました。

Icon

AutoCreateInvoiceEmail

1 file(s) 28.33 KB
Download

このエクセルファイルの作り方

①マクロを使えるようにする
「マクロを使えるようにする」を参照

②ボタンを配置する
　※ ボタンの配置方法は「表を複数の条件で絞り込む②」を参照

③ボタン配置時の以下の画面で「マクロ名」を「CreateEmail」として「新規作成」を押す

④ 「Microsoft Visual Basic for Applications」にて以下のコードを記載

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
Sub CreateEmail()
 
    Dim oApp       As Object
    Dim objMail    As Object
     
    Dim subjectBodyWorksheet As Object: Set subjectBodyWorksheet = ThisWorkbook.Worksheets("件名・本文")
    Dim subject As String: subject = subjectBodyWorksheet.Cells(1, 2).Value
    Dim body As String: body = subjectBodyWorksheet.Cells(2, 2).Value
    Dim attachmentPath As String: attachmentPath = subjectBodyWorksheet.Cells(3, 2).Value
     
    Dim firstRow As Long: firstRow = 2
    Dim lastRow As Long: lastRow = ThisWorkbook.Worksheets("宛先リスト").Cells(Rows.Count, 1).End(xlUp).Row
    Dim companyNameRow As Integer: companyNameRow = 1
    Dim departmentNameRow As Integer: departmentNameRow = 2
    Dim staffNameRow As Integer: staffNameRow = 3
    Dim honorificTitleRow As Integer: honorificTitleRow = 4
    Dim mailAddressRow As Integer: mailAddressRow = 5
     
     
     
    For y = firstRow To lastRow
       Dim addressListWorksheet As Object: Set addressListWorksheet = ThisWorkbook.Worksheets("宛先リスト")
        
       Dim companyName As String: companyName = addressListWorksheet.Cells(y, companyNameRow).Value
       Dim departmentName As String: departmentName = addressListWorksheet.Cells(y, departmentNameRow).Value
       Dim staffName As String: staffName = addressListWorksheet.Cells(y, staffNameRow).Value
       Dim honorificTitle As String: honorificTitle = addressListWorksheet.Cells(y, honorificTitleRow).Value
       Dim mailAddress As String: mailAddress = addressListWorksheet.Cells(y, mailAddressRow).Value
     
       'メールアドレス列がからの場合は飛ばす
       If mailAddress = "" Then
          GoTo Continue
       End If
     
       'メールオブジェクト生成
       On Error Resume Next
       Set oApp = GetObject(, "Outlook.Application")
       On Error GoTo 0
       If oApp Is Nothing Then
          Set oApp = CreateObject("Outlook.Application")
          oApp.GetNamespace("MAPI").GetDefaultFolder(6).display
       End If
       Set objMail = oApp.CreateItem(0)
     
       '各変数の置換
       Dim adjustBody As String: adjustBody = body
       adjustBody = Replace(adjustBody, "&CompanyName", companyName)
       adjustBody = Replace(adjustBody, "&DepartmentName", departmentName)
       adjustBody = Replace(adjustBody, "&StaffName", staffName)
       adjustBody = Replace(adjustBody, "&HonorificTitle", honorificTitle)
     
       '各メールの要素をセット
       With objMail
          .To = mailAddress
          .subject = subject
          .body = adjustBody
          .BodyFormat = 1
       End With
        
       '請求書添付
       AttachFile objMail, attachmentPath, companyName
        'メール表示
       objMail.display
     
Continue:
    Next y
     
     
    Set objMail = Nothing
    Set oApp = Nothing
End Sub
 
Sub AttachFile(ByVal objMail As Object, ByVal attachmentPath As String, ByVal companyName As String)
 
    If attachmentPath = "" Then
        Exit Sub
    End If
     
 
    Dim path, fso, file, files
     
        'ファイル格納フォルダ
        path = attachmentPath
     
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set files = fso.GetFolder(path).files
     
            'フォルダ内の全ファイルをループ
            For Each file In files
     
                'companyNameを含むファイルを特定
                If InStr(file.Name, companyName) >= 1 Then
     
                    objMail.Attachments.Add (file.path)
     
                End If
            Next file
End Sub