【ChatGPＴ活用】ExcelマクロでOutlookからメールを送信する方法！

ヒヤリハットの対応をしなければ・・・
改善ポイントを洗い出す
問題点に対する対策案
1. ①③承認者＆私への連絡が抜ける。
  1. 下準備
  2. 開発タブからマクロを入力する
2. ②担当者が対応欄への記入を忘れる

ヒヤリハットの対応をしなければ・・・

私の会社では排ガスを排出する装置があるため、排ガス分析計を設置して分析計の指示が正確であるか、試験課にて測定した値と照合する業務があります。こちらについては下記のようなExcelに値を入力することで許容範囲内が判定しており、許容誤差を外れた場合は私に連絡し対応を取る必要があります。

しかし、今回わたしへの連絡抜けが発生するヒヤリハットが発生しました。ヒヤリハットの内容は

最初は担当者は許容誤差範囲内に入っていたと課内に周知した。
後日わたしが上記Excelを確認すると試験課測定値が入力されおらず確認すると不合格だった
経緯を聞くと保存し忘れたかも…、試験課測定値をそもそも入力してなかった　と最初に聞いた話と二転三転して何が本当の原因か分からない

上記のような経緯のため、当事者による対策は当てにならないと考え、人に頼らない連絡系統の確立を目的にこの業務の改善を考えていきます。※合わせて今まで溜め込んでいたこの業務に関する不満点も改善していきます。

改善ポイントを洗い出す

現在改善したい項目は以下の内容です

許容管理値外れをした際に私への連絡が抜ける。(他の人に連絡する・連絡自体抜ける)
担当者が対応欄への記入を忘れる
担当者が承認者への連絡を忘れる。(担当者名と承認者名は担当者が纏めて記載している)

問題点に対する対策案

①③承認者＆私への連絡が抜ける。

・Excel VBAによりExcelブック保存時に承認者へOutlookでメールを送るようにする。　　　　　　　　　　　⇒許容誤差外れた場合はわたしにも連絡が行くようにする。　　

・PowerAutomateでExcelの特定セルを監視し、入力されたら承認者へ連絡する。　　　　　　　　　　⇒許容誤差外れた場合はわたしにも連絡がいくようにする

すぐに思いついた案は以上の2つで今回の場合はExcel VBAによる改善を行いたいと思います。

下準備

①Outlookでメールを送る人のメールアドレスを指定する

下記のようにG列にメールアドレスを記入する

開発タブからマクロを入力する

下記のようなコードをChatGPTを使用して作成しました。

C9セルに文字が記載されているときにExcelを保存しようとするとG3セルに記入されているメールアドレスに連絡するようにメッセージが出て、Yesを押すとメール送信する。また、C9セルに不合格と入力されているとG4セルに入力されているメールアドレスにもメール送信する。

こちらのコードをExcel開発タブのVisual Basicボタンを押しコードをコピペすることで対応可能です。

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

    Dim ws As Worksheet
    Dim mailApp As Object
    Dim mailItem As Object
    Dim sendTo As String
    Dim sendToExtra As String
    Dim msg As String
    Dim ans As VbMsgBoxResult
    
    Set ws = ThisWorkbook.Sheets(1) ' 必要に応じてシート名を指定
    
    ' C9に文字があるか確認
    If Trim(ws.Range("C9").Value) <> "" Then
        
        sendTo = Trim(ws.Range("G3").Value)
        sendToExtra = Trim(ws.Range("G4").Value)
        
        msg = "C9セルに文字が入力されています。" & vbCrLf & _
              "次のアドレスに連絡しますか？" & vbCrLf & sendTo
        
        ans = MsgBox(msg, vbYesNo + vbQuestion, "メール送信確認")
        
        If ans = vbYes Then
            ' Outlookアプリケーションを取得
            On Error Resume Next
            Set mailApp = GetObject(Class:="Outlook.Application")
            If mailApp Is Nothing Then
                Set mailApp = CreateObject("Outlook.Application")
            End If
            On Error GoTo 0
            
            If Not mailApp Is Nothing Then
                ' --- G3宛てメール ---
                Set mailItem = mailApp.CreateItem(0)
                With mailItem
                    .To = sendTo
                    .Subject = "Excel保存時の自動通知"
                    .Body = "分析誤差確認表に入力がありましたのでご確認お願いいたします。"
                    .Send
                End With
                
                ' --- C9が「不合格」ならG4宛ても送信 ---
                If ws.Range("C9").Value = "不合格" And sendToExtra <> "" Then
                    Set mailItem = mailApp.CreateItem(0)
                    With mailItem
                        .To = sendToExtra
                        .Subject = "Excel保存時の自動通知（不合格）"
                        .Body = "分析計誤差確認表に「不合格」と入力されたためご連絡いたします。"
                        .Send
                    End With
                End If
            Else
                MsgBox "Outlookが利用できません。", vbExclamation
            End If
        End If
    End If

End Sub

②担当者が対応欄への記入を忘れる

・こちらについては簡単に合否判定が不合格になった際に、対応欄に記入が無ければ保存出来ないようにExcel VBAで制限します。こちらもChatGPTにコードを書いてもらいました。

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1) ' シート名がある場合は変更
    
    ' --- C9が「不合格」で、かつC11が空欄の場合 ---
    If ws.Range("C9").Value = "不合格" And Trim(ws.Range("C11").Value) = "" Then
        MsgBox "対応欄に対応した内容を記載しないと保存できません", vbCritical
        Cancel = True  ' 保存処理を中止
    End If

End Sub