【コピペでできる】Excelでまとめたリストからメールを一括送信！出欠表の効率化！

Excelで、まとめたリストから一括でメール送信できれば便利ですよね

例えば、
・出欠表から参加者だけに案内メールを送りたい
・提出物の未提出者のみへ催促のメールを送りたい

連絡先からいちいち一人ずつ
宛先に追加してると大変で・・・

そんな悩みをExcel VBAで解決！

Excelでまとめたリストから対象者のみを
宛先に追加したメールを作成する機能を作ってみたよ！

対象者のみって？

例えば、こんな時に使えるよ
・出欠表から参加者のみにメールを送りたい
・提出物が未提出の人のみにメールを送りたい

Excelのリストと連絡先を見比べなくて済むんだね！

サンプルソースを掲載しています
ぜひご活用下さい！

こんな人におすすめ
・Excelでまとめたリストからメールを作成したい
・出欠表の出席者だけを宛先に指定したメールを作成したい

機能説明
メール一括送信サンプルソース
1. 出欠表シート
2. メールクラスモジュール
まとめ

機能説明

メーラのパスを青いセルに指定します
今回はサンダーバードを使用しています

宛先対象文字列セル「C6」に指定した文字列をB列から検索
同じ文字列の場合、メールの宛先に追加します

今回の場合「○」が対象ですね

出席者列には「○」の文字列の人数をカウントしています

出席者の人数がわかりますね

出欠表を埋めたら「メール作成」ボタンをクリック

「○」を指定した人のみ
宛先に追加されたメールが作成されました

メール一括送信サンプルソース

VBAのサンプルソースの解説をしていきます

VBAを操作するために「開発」タブ → 「Visual Basic」をクリック

出欠表シート

'*****************************************************
' 機　能：メール作成
' 備　考：
' 作成日：2022.01.20
' 更新日：
'*****************************************************


'*****************************************************
' 定数
'*****************************************************

'--メールアプリパス
Const RANGE_MAIL_APPS_PATH As String = "A4"

'--宛先対象文字列セル
Const RANGE_ATTENDANCE As String = "C6"

'--宛先 列範囲
Const RANGE_ATTENDANCE_COLUMN As String = "B:B"

'--メール送信対象区分文字列
Const RANGE_ATTENDANCE_KUBUN As String = "C6"

'--宛先 列
Const COLUMN_ATTENDANCE As String = "B"
'--メールアドレス列
Const COLUMN_MAIL_ADDRESS As String = "C"


'*****************************************************
' イベント
'*****************************************************


'
' 機    能:メール送信ボタンクリック
'
' 機能説明:なし
'
' 引    数:
'
' 返 り 値:
'
' 備  　考:なし
'
Private Sub btnCreateSendMail_Click()
    On Error GoTo ErrorHandler
    
        Dim clsMail As New mail_class
        Dim mailAppPath As String
        Dim toMailAddressList As New Collection
        
        '--メールアプリパスの取得
        mailAppPath = Range(RANGE_MAIL_APPS_PATH).Value
        
        '--メールアプリの指定がない場合のエラー
        If clsMail.isExistFile(mailAppPath) = "" Then
            MsgBox "メールアプリのパスを指定してください。"
        Else
            If clsMail.isExistFile(mailAppPath) Then
                
                '--宛先対象メールアドレスのリストの取得
                Set toMailAddressList = getToAddresList(Range(RANGE_ATTENDANCE_KUBUN).Value)
                
                '--メール作成
                Call clsMail.createSendMail(mailAppPath, toMailAddressList)
            Else
                MsgBox "メールアプリパス：" & mailAppPath & "が存在しません。"
            End If
        End If
    Exit Sub

ErrorHandler:
    '-- 例外処理
    MsgBox "何らかの理由でメール作成に失敗しました。" & vbCrLf & vbCrLf & "エラーNo:" & Err.Number & vbCrLf & "エラーメッセージ :" & Err.Description, vbCritical & vbOKOnly, "エラー"

End Sub

'*****************************************************
' 関数
'*****************************************************

'
' 機    能:指定した出欠状況の宛先追加
'
' 機能説明:なし
'
' 引    数:宛先追加の対象文字列
'
' 返 り 値:宛先追加対象文字列リスト
'
' 備  　考:なし
'
Public Function getToAddresList(joinStr As String) As Collection
    Dim endRowCount As Long
    Dim attendanceStr As String
    Dim attendanceRow As Integer
    Dim toMailAddressList As Collection
    Set toMailAddressList = New Collection

    endRowCount = Cells(Rows.Count, COLUMN_MAIL_ADDRESS).End(xlUp).Row
    
    
    attendanceRow = getAttendanceRow()

    For i = attendanceRow To endRowCount
        If joinStr = Range(COLUMN_ATTENDANCE & i).Value Then
            If "" <> Range(COLUMN_MAIL_ADDRESS & i).Value Then
                toMailAddressList.Add Range(COLUMN_MAIL_ADDRESS & i).Value
            End If
        End If
    Next i


    Set getToAddresList = toMailAddressList
End Function

'
' 機    能:出欠状況確認の最終行数を取得
'
' 機能説明:なし
'
' 引    数:なし
'
' 返 り 値:最終行数
'
' 備  　考:なし
'
Public Function getAttendanceRow() As Integer
    Dim myRange     As Range
    Dim myObj       As Range
    Dim keyWord     As String
    Dim maxRow As Integer
    
    Set myRange = Range(RANGE_ATTENDANCE_COLUMN)
    keyWord = Range(RANGE_ATTENDANCE).Value
    Set myObj = myRange.Find(keyWord, LookAt:=xlWhole)
    getAttendanceRow = myObj.Row
    
End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

'*****************************************************

' 機　能：メール作成

' 備　考：

' 作成日：2022.01.20

' 更新日：

'*****************************************************

' 定数

'*****************************************************

'--メールアプリパス

Const RANGE_MAIL_APPS_PATH As String = "A4"

'--宛先対象文字列セル

Const RANGE_ATTENDANCE As String = "C6"

'--宛先列範囲

Const RANGE_ATTENDANCE_COLUMN As String = "B:B"

'--メール送信対象区分文字列

Const RANGE_ATTENDANCE_KUBUN As String = "C6"

'--宛先列

Const COLUMN_ATTENDANCE As String = "B"

'--メールアドレス列

Const COLUMN_MAIL_ADDRESS As String = "C"

'*****************************************************

' イベント

'*****************************************************

' 機能:メール送信ボタンクリック

' 機能説明:なし

' 引数:

' 返り値:

' 備　考:なし

Private Sub btnCreateSendMail_Click()

On Error GoTo ErrorHandler

Dim clsMail As New mail_class

Dim mailAppPath As String

Dim toMailAddressList As New Collection

'--メールアプリパスの取得

mailAppPath = Range(RANGE_MAIL_APPS_PATH).Value

'--メールアプリの指定がない場合のエラー

If clsMail.isExistFile(mailAppPath) = "" Then

MsgBox "メールアプリのパスを指定してください。"

Else

If clsMail.isExistFile(mailAppPath) Then

'--宛先対象メールアドレスのリストの取得

Set toMailAddressList = getToAddresList(Range(RANGE_ATTENDANCE_KUBUN).Value)

'--メール作成

Call clsMail.createSendMail(mailAppPath, toMailAddressList)

Else

MsgBox "メールアプリパス：" & mailAppPath & "が存在しません。"

End If

Exit Sub

ErrorHandler:

'-- 例外処理

MsgBox "何らかの理由でメール作成に失敗しました。" & vbCrLf & vbCrLf & "エラーNo:" & Err.Number & vbCrLf & "エラーメッセージ :" & Err.Description, vbCritical & vbOKOnly, "エラー"

End Sub

'*****************************************************

' 関数

'*****************************************************

' 機能:指定した出欠状況の宛先追加

' 機能説明:なし

' 引数:宛先追加の対象文字列

' 返り値:宛先追加対象文字列リスト

' 備　考:なし

Public Function getToAddresList(joinStr As String) As Collection

Dim endRowCount As Long

Dim attendanceStr As String

Dim attendanceRow As Integer

Dim toMailAddressList As Collection

Set toMailAddressList = New Collection

endRowCount = Cells(Rows.Count, COLUMN_MAIL_ADDRESS).End(xlUp).Row

attendanceRow = getAttendanceRow()

For i = attendanceRow To endRowCount

If joinStr = Range(COLUMN_ATTENDANCE & i).Value Then

If "" <> Range(COLUMN_MAIL_ADDRESS & i).Value Then

toMailAddressList.Add Range(COLUMN_MAIL_ADDRESS & i).Value

End If

Next i

Set getToAddresList = toMailAddressList

End Function

' 機能:出欠状況確認の最終行数を取得

' 機能説明:なし

' 引数:なし

' 返り値:最終行数

' 備　考:なし

Public Function getAttendanceRow() As Integer

Dim myRange As Range

Dim myObj As Range

Dim keyWord As String

Dim maxRow As Integer

Set myRange = Range(RANGE_ATTENDANCE_COLUMN)

keyWord = Range(RANGE_ATTENDANCE).Value

Set myObj = myRange.Find(keyWord, LookAt:=xlWhole)

getAttendanceRow = myObj.Row

End Function

メールクラスモジュール

他のプログラムにも使用できるよう

共通化したクラスモジュールを作成します

メール送信クラスというイメージでクラス名を指定しました

'*****************************************************
' 機　能：メール関連クラス
' 備　考：
' 作成日：2022.01.20
' 更新日：
'*****************************************************

'*****************************************************
' 定数
'*****************************************************

'--メール作成コマンド
Const CREATE_MAIL_COMMAND As String = " -compose "

'*****************************************************
' 関数
'*****************************************************

'
' 機    能:送信メール作成
'
' 機能説明:なし
'
' 引    数:メールアプリパス 宛先メールアドレスリスト
'
' 返 り 値:なし
'
' 備  　考:なし
'
Public Sub createSendMail(mailAppPath As String, toMailAddressList As Collection)
    Dim mailadto As String

    '--メールアドレスリストから宛先へ追加してメールを作成
    For Each toMailAddress In toMailAddressList
        mailadto = mailadto & toMailAddress & " ; "
    Next toMailAddress
    
    If mailadto = "" Then
        MsgBox "メール送信対象者が存在しません。"
    Else
        Shell mailAppPath + CREATE_MAIL_COMMAND & "to=" & mailadto
    End If

End Sub

'
' 機    能:ファイル存在チェック
'
' 機能説明:なし
'
' 引    数:アプリパス
'
' 返 り 値:TRUE:存在/FALSE:存在しない
'
' 備  　考:なし
'
Public Function isExistFile(mailAppPath As String)
    Dim result As Boolean
    If Dir(mailAppPath) <> "" Then
         result = True
    Else
         result = False
    End If
    isExistFile = result
End Function

'*****************************************************

' 機　能：メール関連クラス

' 備　考：

' 作成日：2022.01.20

' 更新日：

'*****************************************************

' 定数

'*****************************************************

'--メール作成コマンド

Const CREATE_MAIL_COMMAND As String = " -compose "

'*****************************************************

' 関数

'*****************************************************

' 機能:送信メール作成

' 機能説明:なし

' 引数:メールアプリパス宛先メールアドレスリスト

' 返り値:なし

' 備　考:なし

Public Sub createSendMail(mailAppPath As String, toMailAddressList As Collection)

Dim mailadto As String

'--メールアドレスリストから宛先へ追加してメールを作成

For Each toMailAddress In toMailAddressList

mailadto = mailadto & toMailAddress & " ; "

Next toMailAddress

If mailadto = "" Then

MsgBox "メール送信対象者が存在しません。"

Else

Shell mailAppPath + CREATE_MAIL_COMMAND & "to=" & mailadto

End If

End Sub

' 機能:ファイル存在チェック

' 機能説明:なし

' 引数:アプリパス

' 返り値:TRUE:存在/FALSE:存在しない

' 備　考:なし

Public Function isExistFile(mailAppPath As String)

Dim result As Boolean

If Dir(mailAppPath) <> "" Then

result = True

Else

result = False

End If

isExistFile = result

End Function

まとめ

今回できたことなど
・まとめたリストから一括で宛先指定したメールの作成
・出欠確認のち出席者のみを指定したメール作成が可能
・出欠表シートの定数部分を変更することでセルの位置も変更可能

業務の効率化に繋がれば嬉しいです

機能説明

メール一括送信 サンプルソース

出欠表シート

メールクラスモジュール

まとめ

コメント

メール一括送信サンプルソース