OutLookに来る日付がばらばらの予定メールをExcelで予定日順に整理したい

きっかけ

業務の都合で営業の予定が自分の手元に回ってくる。
がっつり参加するわけでもないので完全に把握する必要はないが、
そのタイミングで席を離れづらいタスクを進めると少し面倒なので、
「今日は何か予定があったかな」
をざっくり把握しておきたかった。

受信日と予定日の順番は必ずしも一致せず、
今日来たメールが明日の予定だったり、
昨日来たメールが2か月後の予定だったりする。

VBAは6年ほど前にバイトでちょろっと触っていたがほぼ覚えていなかったので
半分ぐらいchatGPTに頼りつつ、手直しは自分で進めた。

メールのフォーマット

件名

【営業】 MM月dd日　(アポ先)

が決まりのフォーマット。ただし、日付は手打ちなので
MM/dd、M月d日、M/dd
等が入り混じる。

予定の中止/変更に関しては件名に
【中止】【変更】などが追加されている。

本文

・予定日: MM月dd日(件名と同じ)
・時間帯: HH時～HH時ごろ
・お相手: (アポ先社員名)
・以下打合せ場所などの情報

構想

最低限の要件

・目的である予定日順での自動ソートは必須
・メールから予定日を取得する方法が必要
→日付のフォーマットが不定形…正規表現でいけるかな。

さすがに処理がもっさりするのは嫌なので…

・最終取得時間以降に受信したメールのみ処理したい
・ついでに予定日が過去のメールは削除しておこう

1セルずつ書き込みだと遅くなったような記憶…
・結果を配列にまとめて、メールの処理が全て終わってから一括でシートに貼り付け

その他決めていた事項

・丁寧に作った結果の細かいメンテナンスは嫌なのでざっくりした機能で作る

予定変更や中止のメールをどうするか？

・上の「丁寧に作りすぎない」を理由に、どのメールに対する変更かまでは探さない
( == 1件のメールとして処理を行う)

・取りこぼしがないように日付がないメールも件名などの情報を取得する

補足

元々OutLook内の機能で【営業】をキーとして「営業」というフォルダに振り分けるルールを作っていた。
これをそのまま処理対象のフォルダとすることで、処理対象となるメールの件数を絞りつつ、正規表現は日付のみとしても誤検知がない状態になっている。

PCのスタートアップアプリにOutLookが含まれているので、
・VBAでOutLookの立ち上げ時に指定のExcelファイルに書き込み
・今日が予定のものがあればポップアップなどで通知

…をしたかったが、セキュリティの都合で起動毎にOutLookのVBAがリセットされてしまう。

という事情もあり、仕方ないのでExcelにVBAを書くことにした。
自動実行ができないなら毎朝1回開くことになるので通知とかはなし。

実際のコード

上の構想から
B1セルに最終取得時間を入力し、更新時に参照する。
最終取得時間がない場合は全件取得。

A4～C4以降の行にメールの
・受信時間
・予定日
・例外(中止など)
・件名

を入力する形にした。
削除機能なども作成はしたが、OutLookオブジェクトの宣言周りを再利用するためにモジュールの分割など自力で行った部分がchatGPTのログに残っていなかったので割愛。
取得してソートするまでの部分のみを記載する。

VBAコード

Sub GetNewOutlookEmailsSinceLastRun()
    ' Outlookオブジェクトの宣言
    Dim OutlookApp As Object
    Dim OutlookNamespace As Object
    Dim OutlookFolder As Object
    Dim TargetFolder As Object
    Dim OutlookMail As Object
    Dim i As Long
    Dim ws As Worksheet
    Dim LastRow As Long
    Dim LastRunDate As Date
    Dim NewEmailsOnly As Boolean
    Dim subject As String
    Dim regexDate As String
    Dim regexInfo As String
    Dim result() As Variant  ' 結果を配列で保持する
    Dim emailCount As Long
    Dim rowIndex As Long
    Dim foundEmails As Boolean ' メールが見つかったかのフラグ
    
    ' メールが見つかったかどうかのフラグ初期化
    foundEmails = False
    
    ' 現在のシートを取得
    Set ws = ThisWorkbook.Sheets(1)
    
    ' 前回の取得日時をB2セルから取得
    If IsDate(ws.Cells(1, 2).Value) Then
        LastRunDate = CDate(ws.Cells(1, 2).Value)
        NewEmailsOnly = True
    Else
        NewEmailsOnly = False
    End If
    
    ' 今回のマクロ実行日時をB2セルに保存
    ws.Cells(1, 2).Value = Now
    
    ' Outlookアプリケーションの取得
    Set OutlookApp = GetOutlookApp()
    If OutlookApp Is Nothing Then
        MsgBox "Outlookが開かれていません。"
        Exit Sub
    End If
    
    ' 名前空間の取得
    Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
    
    ' "営業"フォルダの取得
    Set TargetFolder = GetOutlookFolder("営業", OutlookNamespace)
    If TargetFolder Is Nothing Then
        MsgBox "フォルダ '営業' が見つかりません。"
        Exit Sub
    End If
    
    ' A列の最終行を取得し、その次の行から入力する
    LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1
    
    ' メールの数を見積もり、配列を準備
    emailCount = TargetFolder.Items.Count
    ReDim result(1 To emailCount, 1 To 4) ' 4列に対応
    
    ' メールの受信日をA列、件名をC列の最終行から書き込む
    rowIndex = 1
    For Each OutlookMail In TargetFolder.Items
        ' 新しいメールのみ取得する場合
        If NewEmailsOnly Then
            If OutlookMail.ReceivedTime <= LastRunDate Then
                GoTo ContinueFor
            End If
        End If
        
        ' フラグをTrueに設定（メールが見つかった）
        foundEmails = True
        
        ' 受信日、件名、日付、情報を配列に格納
        result(rowIndex, 1) = OutlookMail.ReceivedTime
        subject = OutlookMail.subject
        result(rowIndex, 4) = subject
        
        ' B列に件名から日付抽出したものを入力
        regexDate = "\b([1-9]|1[0-2])/([1-9]|[12]\d|3[01])\b|([1-9]|1[0-2])月([1-9]|[12]\d|3[01])日"
        result(rowIndex, 2) = GetMatchedRegex(regexDate, subject, -1)
        
        ' C列に件名から抽出したものを入力
        regexInfo = "中止|変更"
        result(rowIndex, 3) = GetMatchedRegex(regexInfo, subject, -1)
        
        rowIndex = rowIndex + 1
ContinueFor:
    Next OutlookMail
    
    ' メールが見つからなかった場合の処理
    If Not foundEmails Then
        MsgBox "新しいメールはありませんでした。"
        Exit Sub
    End If
    
    ' 見つかったメールがある場合はシートに一括で貼り付け
    ws.Range("A" & LastRow).Resize(rowIndex - 1, 4).Value = result
    
    ' メール処理が完了した後、B列を基準にソート
    Call SortByColumnB(ws, LastRow, LastRow + rowIndex - 2)
    
    ' メッセージ完了
    MsgBox "営業フォルダから新しいメール情報の取得が完了しました！"
    
    ' オブジェクトの解放
    ReleaseObject OutlookMail
    ReleaseObject TargetFolder
    ReleaseObject OutlookNamespace
    ReleaseObject OutlookApp
End Sub

コードにない範囲でやったこと

・メールの削除機能
・Excelシートのリセット(バグなどを全件再取得で済ませるため)

・モジュール分割
OutLookの宣言部分や、正規表現に一致する文字列取得の部分を共通モジュールに持っていきメール削除時も使いまわすようにした

・処理後のメッセージボックスに処理件数を出力するようにした

感想

昔からある言語ということもあり、教材が多いせいか、ChatGPTの出力の精度は(当社比)かなりいい気がする。手直ししたコードを食わせてここを変えたいといった指令も難なく対応していた。

その他残っている修正点

変数名

変数名がキャメルケースだったりアッパーキャメルケースだったりする

処理の仕方

・メール処理
・シートの末尾に貼り付け
・ソート

にしているが、
・現在のシート状況を取得して配列(コレクション)に入れる
・メールを処理して配列に追加
・配列をソート
・シートに一括で貼り付け

とする方が多分処理は早い。
予定日の部分が正規表現だけでは文字列であり、年数がない都合でDate型に直す部分が面倒。
文字列だと辞書順になってしまうので大小比較が困難。
なので、シートの書式設定でB列をDate型と指定した上で、
貼り付けた後シートに対するソートとすることでうまいことやった顔をしている。

ソートが不正確

ここができるなら一番直しておきたい部分。
件名から予定日の年数を取得できず、今は来年1月の予定が入ったら2024年1月扱いになって一番上に来てしまう。

正規表現から月の部分だけ抜き出したうえで現在の月と比較して年数を文字列に追加して…という感じでできないことはないがどうしても工程が増えてしまう。面倒。

なお、メールの削除については年数を付与するのではなく今月と予定の月が前後3カ月以内か、という比較にしている。(10月なら9,8,7月が予定日のメールのみ削除、1月なら12,11,10月が削除対象)

来年の1月に不要メールを削除して全件再取得でいいか、という構えをとっている。

配列の使い方

横着して正規表現の抽出→Excelシートへの出力に直接Variantの配列を使用しているが、本当に丁寧にやるなら構造体を作る方が型と不一致でのエラーを検知しやすくなるので

Type SalesScheduleMail
    Received As Date
    Scheduled As String
    Information As String
    Subject As String
End Type

' メールのfor文
Dim Mails (1 to emailCount) As SalesScheduleMail

みたいにしておくべきだったのかなと思うが、最終的には構造体からVariantの配列に出力してまとめてExcelシートに貼り付けが一番処理時間は早くなるはずなのでこれでもいいかなという気持ち。