某小売業で教育を担当しているにゃろめです。
私は社内資格者育成のための研修運営を担当しています。２月の年度末が近づくと年間や半期を通じて実施してきた研修も終盤となり、最後の「認定試験」を迎えます。
そして「認定試験」が無事終わると、合否結果を店舗に連絡するお仕事が待っています。
合否発表の流れをざくっと言うと、こんな流れ。
合否を出す➡
Excelでまとめる➡
Excelで結果通知書を作成➡
PDF化➡メールに添付
➡店舗の店長へ送付
10人、20人くらいならそんな苦ではないのですが、
ぼんやり来年1月～2月のスケジュールを考えると、、、
あれ？
短期間に100名くらいの作らなあかんやん…( ﾟДﾟ)
これは何とかしなければ！！！
ということで、今年私が手に入れた武器「VBA」で自動化すべく、
相棒チャッピー（ChatGPT）に相談。
業務の合間にさくっとマクロを作成してみました🙌
以下のことをマクロで自動！！
・「合否結果」から自動判別、「認定」「未認定」シートの特定セルにNo.を自動入力
（自動入力されたらExcel関数でシートの中身が変わります）
・全員分の通知書をPDFで保存
・Excelシートに入力しているアドレス宛てのメールを自動作成＋PDFも自動添付
💻作成開始！！！
先にこのようなExcelシートを準備（以前から使用していたものを少し加工）
チャッピーへのプロンプト
（相変わらず指示が下手だ…）
excel VBAを教えて下さい。以下が実施したいことです。
・「【】●●認定試験結果 通知書」というExcelファイルがあります。
・ファイル内には「結果」「認定」「未認定」のシートがあります。
「結果」シートは１行目が見出し、２行目以下データが入っています。
見出しの「合否結果」のデータを見て「認定」であれば「認定」シートのA13セルに、
見出し「No.」 列にある（A列）番号を入れてください。
「未認定」であれば「未認定」シートのA13セルに「No.」列にある番号を入力
・１行目が終わったら「認定」シート「未認定」シートどちらか（番号を入力した方）を保存
下手なプロンプトでもチャッピーはなんとか理解してくれました🥲
チャッピーが教えてくれたコード
Sub 結果を認定未認定シートへ転記して保存()
Dim wb As Workbook
Dim wsResult As Worksheet
Dim wsNintei As Worksheet
Dim wsMiNintei As Worksheet
Dim lastRow As Long
Dim i As Long
Dim colGohi As Long '「合否結果」列
Dim colNo As Long '「No.」列
Dim nextRowNintei As Long
Dim nextRowMiNintei As Long
Dim valGohi As String
Dim valNo As Variant
Dim haveNintei As Boolean
Dim haveMiNintei As Boolean
Dim basePath As String
Dim baseName As String
Set wb = ThisWorkbook
Set wsResult = wb.Worksheets("結果")
Set wsNintei = wb.Worksheets("認定")
Set wsMiNintei = wb.Worksheets("未認定")
'--- 見出し行（1行目）から「合否結果」「No.」の列番号を探す ---
colGohi = 0
colNo = 0
For i = 1 To wsResult.Cells(1, wsResult.Columns.Count).End(xlToLeft).Column
Select Case wsResult.Cells(1, i).Value
Case "合否結果"
colGohi = i
Case "No."
colNo = i
End Select
Next i
If colGohi = 0 Or colNo = 0 Then
MsgBox "「結果」シートの1行目に「合否結果」または「No.」の見出しが見つかりません。", vbExclamation
Exit Sub
End If
'--- 「結果」シートの最終行 ---
lastRow = wsResult.Cells(wsResult.Rows.Count, colNo).End(xlUp).Row
If lastRow < 2 Then
MsgBox "「結果」シートにデータがありません。", vbExclamation
Exit Sub
End If
'--- 「認定」「未認定」シートの書き込み開始行（A13から） ---
nextRowNintei = wsNintei.Cells(wsNintei.Rows.Count, "A").End(xlUp).Row
If nextRowNintei < 13 Then
nextRowNintei = 13
Else
nextRowNintei = nextRowNintei + 1
End If
nextRowMiNintei = wsMiNintei.Cells(wsMiNintei.Rows.Count, "A").End(xlUp).Row
If nextRowMiNintei < 13 Then
nextRowMiNintei = 13
Else
nextRowMiNintei = nextRowMiNintei + 1
End If
haveNintei = False
haveMiNintei = False
'--- 「結果」シートを2行目からループ ---
For i = 2 To lastRow
valGohi = CStr(wsResult.Cells(i, colGohi).Value)
valNo = wsResult.Cells(i, colNo).Value
If valGohi = "認定" Then
wsNintei.Cells(nextRowNintei, "A").Value = valNo
nextRowNintei = nextRowNintei + 1
haveNintei = True
ElseIf valGohi = "未認定" Then
wsMiNintei.Cells(nextRowMiNintei, "A").Value = valNo
nextRowMiNintei = nextRowMiNintei + 1
haveMiNintei = True
End If
Next i
'--- 保存処理（シートを別ブックとして保存）---
basePath = wb.Path
If basePath = "" Then
' まだ保存していないブックの場合
MsgBox "まず、このブックを一度保存してください。", vbExclamation
Exit Sub
End If
baseName = Left(wb.Name, InStrRev(wb.Name, ".") - 1)
'「認定」シートに番号を入力した場合
If haveNintei Then
wsNintei.Copy
With ActiveWorkbook
.SaveAs Filename:=basePath & "\" & baseName & "_認定.xlsx", _
FileFormat:=xlOpenXMLWorkbook
.Close SaveChanges:=False
End With
End If
'「未認定」シートに番号を入力した場合
If haveMiNintei Then
wsMiNintei.Copy
With ActiveWorkbook
.SaveAs Filename:=basePath & "\" & baseName & "_未認定.xlsx", _
FileFormat:=xlOpenXMLWorkbook
.Close SaveChanges:=False
End With
End If
MsgBox "処理が完了しました。", vbInformation
End Sub
このあとに、以下の指示を追加
・Excelは上書き保存ではなく、PDFで１つ１つ保存
・PDFのシート名は【】に「店舗名＋苗字＋さん」を入れる
・PDF作成後、outlookを起動しPDFを自動添付
・その際、同じ店舗の受講生は1つのメールに添付するようにする
・メールアドレス①の番号を宛先に入力、メールアドレス②③はCCに入力
・メール作成するかどうか選択式（作成しない場合はPDF保存で終わる）
最終できたコード
Option Explicit
' メイン処理
Sub MakePdfAndMail()
Dim wsRes As Worksheet ' 結果
Dim wsPass As Worksheet ' 認定
Dim wsFail As Worksheet ' 未認定
Dim lastRow As Long
Dim i As Long
Dim colNo As Long, colResult As Long, colShop As Long
Dim colName As Long, colMail1 As Long, colMail2 As Long, colMail3 As Long
Dim dict As Object ' 店舗ごとの情報を格納する Dictionary
Dim info As Object ' 店舗ごとの情報（さらに Dictionary）
Dim shop As String, result As String
Dim fullName As String, lastName As String
Dim toAddr As String, cc2 As String, cc3 As String
Dim targetWS As Worksheet
Dim pdfName As String, pdfPath As String
Dim dispName As String
Dim spacePos As Long
Dim ans As VbMsgBoxResult ' メール起動するかどうかの確認用
On Error GoTo ErrHandler
Set wsRes = ThisWorkbook.Worksheets("結果")
Set wsPass = ThisWorkbook.Worksheets("認定")
Set wsFail = ThisWorkbook.Worksheets("未認定")
' 見出し行から列番号を取得
colNo = GetColumnByHeader(wsRes, "No.")
colResult = GetColumnByHeader(wsRes, "合否結果")
colShop = GetColumnByHeader(wsRes, "店舗")
colName = GetColumnByHeader(wsRes, "氏名")
colMail1 = GetColumnByHeader(wsRes, "メールアドレス①")
colMail2 = GetColumnByHeader(wsRes, "メールアドレス②")
colMail3 = GetColumnByHeader(wsRes, "メールアドレス③")
lastRow = wsRes.Cells(wsRes.Rows.Count, colNo).End(xlUp).Row
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To lastRow
If wsRes.Cells(i, colNo).value <> "" Then
result = Trim$(CStr(wsRes.Cells(i, colResult).value))
shop = CStr(wsRes.Cells(i, colShop).value)
fullName = CStr(wsRes.Cells(i, colName).value)
' 合否で使うシートを決定
If result = "認定" Then
Set targetWS = wsPass
ElseIf result = "未認定" Then
Set targetWS = wsFail
Else
' それ以外はスキップ
GoTo NextRow
End If
' ---- No. を A13 にセット ----
targetWS.Range("A13").value = wsRes.Cells(i, colNo).value
' ---- ファイル名の【 ～ 】部分を作成（苗字だけ）----
lastName = fullName
' 半角スペースで区切りを探す
spacePos = InStr(lastName, " ")
If spacePos = 0 Then
' 見つからなければ全角スペースを探す
spacePos = InStr(lastName, " ")
End If
If spacePos > 0 Then
lastName = Left$(lastName, spacePos - 1)
End If
dispName = shop & " " & lastName & "さん"
pdfName = "【" & dispName & "】●●認定試験結果 通知書.pdf"
pdfPath = ThisWorkbook.Path & "\" & pdfName
' ---- PDF 出力 ----
targetWS.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=pdfPath, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
' ==== 店舗ごとの情報を Dictionary に格納 ====
If Not dict.Exists(shop) Then
' 店舗ごとの情報用 Dictionary を作成
Set info = CreateObject("Scripting.Dictionary")
info.Add "To", "" ' To 用文字列
info.Add "CC", "" ' CC 用文字列（; 区切り）
Set info("Files") = New Collection ' 添付ファイル一覧
dict.Add shop, info
End If
Set info = dict(shop)
' メールアドレス（数字でもOK）
toAddr = Trim$(CStr(wsRes.Cells(i, colMail1).Text))
cc2 = Trim$(CStr(wsRes.Cells(i, colMail2).Text))
cc3 = Trim$(CStr(wsRes.Cells(i, colMail3).Text))
' To（同じアドレスが重複しないように）
Call AddAddressUnique(info("To"), toAddr)
' CC（②③ をまとめて重複なしに）
Call AddAddressUnique(info("CC"), cc2)
Call AddAddressUnique(info("CC"), cc3)
' PDF ファイルパスを追加
info("Files").Add pdfPath
End If
NextRow:
Next i
' ===== メールを起動するかどうか確認 =====
ans = MsgBox("Outlook のメールを起動して、店舗ごとのメールを作成しますか？", _
vbYesNo + vbQuestion, "メール作成の確認")
If ans = vbYes Then
' ===== Outlook メール作成 =====
Call CreateOutlookMailByShop(dict)
End If
MsgBox "処理が完了しました。", vbInformation
Exit Sub
ErrHandler:
MsgBox "エラーが発生しました : " & Err.Number & " - " & Err.Description, vbCritical
End Sub
'------------------------------------------------------------
' 見出し行（1行目）から指定した文字の列番号を取得
'------------------------------------------------------------
Private Function GetColumnByHeader(ws As Worksheet, headerText As String) As Long
Dim rng As Range
Set rng = ws.Rows(1).Find(What:=headerText, LookAt:=xlWhole)
If rng Is Nothing Then
Err.Raise vbObjectError + 100, , _
"見出し """ & headerText & """ が見つかりません。"
End If
GetColumnByHeader = rng.Column
End Function
'------------------------------------------------------------
' 文字列で保持しているアドレスリストに、重複が無ければ追加
' strList : "a@a.com;b@b.com" のような文字列（ByRef）
' newAddr : 追加したいアドレス
'------------------------------------------------------------
Private Sub AddAddressUnique(ByRef strList As String, ByVal newAddr As String)
Dim tmp As String
If newAddr = "" Then Exit Sub
' 先頭・末尾にも ; を付けて「;xxx;」の形で検索し、重複を防ぐ
tmp = ";" & strList & ";"
If InStr(1, tmp, ";" & newAddr & ";", vbTextCompare) = 0 Then
If strList = "" Then
strList = newAddr
Else
strList = strList & ";" & newAddr
End If
End If
End Sub
'------------------------------------------------------------
' 店舗ごと（dict）に Outlook メールを作成
' dict(shop)("To") : To アドレス文字列
' dict(shop)("CC") : CC アドレス文字列
' dict(shop)("Files"): 添付ファイルの Collection
'------------------------------------------------------------
Private Sub CreateOutlookMailByShop(ByVal dict As Object)
Dim olApp As Object
Dim olMail As Object
Dim shopKey As Variant
Dim info As Object
Dim f As Variant
' Outlook 起動（既に起動していればそのインスタンスを取得）
Set olApp = CreateObject("Outlook.Application")
For Each shopKey In dict.Keys
Set info = dict(shopKey)
Set olMail = olApp.CreateItem(0) ' 0 = olMailItem
With olMail
.To = info("To")
.cc = info("CC")
.Subject = "●●認定試験結果 通知書"
.Body = shopKey & " ご担当者様" & vbCrLf & vbCrLf & _
"●●認定試験結果の通知書をお送りいたします。" & vbCrLf & _
"添付ファイルをご確認ください。" & vbCrLf & vbCrLf & _
"※本メールは自動送信です。"
' 添付ファイル追加
For Each f In info("Files")
.Attachments.Add CStr(f)
Next f
' すぐ送信したい場合は .Send に変更
.Display
End With
Next shopKey
End Sub
VBAの中の文面を少し変えれば、担当している研修ごとに対応可能。
これで年明けの仕事が少し楽になるはず～
💬余談（PADで初めての業務改善Level.１）
本当はPowerAutomateDesktop（PAD）を使って何かしたくて、
本読んだり動画見たりしてみたけど
ちゃんと腰を据えてやらないと全然理解が追い付かない…
今回の取り組みもVBAとPADで組み合わせてやってみよう！と思ったが
結局VBAで全部完結できちゃうじゃん。
とのことでPAD断念。
うーん、何かPADでしたい！と思って、
便利な「録画機能」を使って
日常の些細な手間をフロー化してみた。
「社内システム接続の自動化フロー」
社内システムに繋げるには、事務所であれば会社のLAN線をPCに繋げるだけで完了。
しかし、私は出張がほとんどなので会社スマホでデザリングして以下の手順が必要。
１. １つのアプリを立ち上げる
２. そこに入力するワンタイムパスワード作成のため、専用サイトに入りパス入力➡ログイン
３. 生成されたワンタイムパスワードをアプリに入力する。
時間は15秒ほどのものなのですが、地味に面倒なので１と２のフロー作成。
これでワンタイムパスワード作成までを自動化。
（約10秒）
手作業でするのと、PAD立ち上げて実行するのとそんな時間的に変わらない。
むしろ面倒な気もする…
（PC起動後自動的に立ち上げるようにしてるんだけど、立ち上がらない…）
でも！自分がPAD使っている嬉しさと、
その数秒何もせず違う作業ができるので、
有意義な自動化だと思っている！！（自己満）
来年も頑張って仕事を楽にしよ～