多数のユーザーの空き時間を一括で取得するマクロ

コメントにて以下のご要望をいただきました。

---

いつも参考にさせていただいています。
素人丸出しの質問になりますが、マクロについて質問させて下さい。

■希望
　他人の予定における【空き時間】の一覧化・抽出

■環境
　Microsoft365

■使用シーン
　業務で面接官の予定調整を行っているのですが、
　面接官となる人間が150人程存在しており、誰が面接予定日に予定が空いているのか、
　現状ではOutlookの予定を目視で確認し割り振りを行っています。

　また、時期によっては3カ月を超える期間にわたって人選をする必要があり、
　面接官の偏りがないようにランダムに抽出する必要があるだけでなく、
　面接官の変更も頻繁に発生するため、手作業では非常に時間がかかる状況です。

以上の問題を解消するために、
【空き時間】の一覧化だけでも出来ないかと考えている次第です。

既にExcelVBAを用いた予定されている他人の予定の抽出や、
スケジュールアシスタントを使用した調整等も試したのですが、
スケジュールアシスタントでは、【参加者全員の予定が合う時間】しか抽出できず、
使用シーンのニーズとは合致していない状況です。

何卒お知恵を拝借したく…。
宜しくお願い致します。

---

Outlook の Recipient オブジェクトの FreeBusy メソッドを使用すると、そのユーザーの空き時間情報を指定された時間単位で 0 または 1 という文字により取得可能です。

一覧化をするにあたっては、Excel に出力されたほうが使い勝手が良いと思いましたので、Excel のマクロから Outlook を呼び出す形でマクロを作ってみました。
このマクロを実行する Excel ファイルのシート 1 の A1 セルには開始日、B1 セルには終了日、A4 セルから下に空き時間情報を取得するユーザーの名前かメールアドレス (Outlook で一意に名前解決できる文字列) を記入しておきます。

以下のようなイメージになるでしょう。

	A	B
1	2022/9/1	2022/11/30
2
3
4	User1
5	User2
6	User3
7	…

そして、以下のマクロを実行することで、1 時間ごとに空き状況が表として出力されます。

'
Public Sub GetFreeBusy()
     Const START_HOUR = 9 ' 始業時間
     Const END_HOUR = 18 ' 終業時間
     Const START_ROW = 4
     Const START_COL = 3
     Const FREE_MARK = "_" ' 空き時間をあらわす文字
     Const BUSY_MARK = "X" ' 予定ありをあらわす文字
     Dim olkApp As Object ' Outlook.Application
     Dim recUser As Object ' Outlook.Recipient
     Dim iRow As Integer
     Dim dtStart As Date
     Dim dtNext As Date
     Dim dtEnd As Date
     Dim iDateSpan As Integer
     Dim iTimeSpan As Integer
     Dim iDate As Integer
     Dim iHour As Integer
     Dim iDateCol As Integer
     Dim strFreeBusy As String
     Dim iTimeSlot As Integer
     Dim strForB As String
     ' Outlook.Application オブジェクトの取得
     Set olkApp = CreateObject("Outlook.Application")
     With ThisWorkbook.Sheets(1)
         ' 開始日と終了日を A:1、B:1 セルから取得
         dtStart = .Cells(1, 1)
         dtEnd = .Cells(1, 2)
         ' 日付の範囲を取得
         iDateSpan = DateDiff("d", dtStart, dtEnd)
         ' 開始時間と終了時間から稼働時間を取得
         iTimeSpan = END_HOUR - START_HOUR
         ' 2-3 行目に日付と時間を出力
         For iDate = 0 To iDateSpan
             iDateCol = START_COL + iDate * iTimeSpan
             ' 日付のセルを結合
             .Range(.Cells(2, iDateCol), .Cells(2, iDateCol + iTimeSpan - 1)).Merge
             ' 日付を設定
             .Cells(2, iDateCol) = DateAdd("d", iDate, dtStart)
             ' 左寄せ
             .Cells(2, iDateCol).HorizontalAlignment = xlLeft
             ' 時間を設定
             For iHour = 0 To iTimeSpan - 1
                 .Cells(3, iDateCol + iHour) = START_HOUR + iHour
                 .Columns(iDateCol + iHour).AutoFit
             Next
         Next
         '
         iRow = START_ROW
         ' A 列が空欄になるまで繰り返し
         While .Cells(iRow, 1) <> ""
             ' A 列からユーザーの名前またはアドレスを取得
             Set recUser = olkApp.Session.CreateRecipient("=" & .Cells(iRow, 1))
             ' 名前解決を実行
             recUser.Resolve
             ' 空き時間を取得
             strFreeBusy = recUser.Freebusy(dtStart, 60)
             ' 指定された日数分空き時間情報が取得できていなければ追加で取得
             While Len(strFreeBusy) / 24 < iDateSpan
                 dtNext = DateAdd("d", Len(strFreeBusy) / 24, dtStart)
                 strFreeBusy = strFreeBusy & recUser.Freebusy(dtNext, 60)
             Wend
             '
             For iDate = 0 To iDateSpan
                 For iHour = 0 To iTimeSpan - 1
                     ' 日数と時間から空き時間情報上の位置を取得
                     iTimeSlot = iDate * 24 + START_HOUR + iHour + 1
                     ' 空き情報を表す文字を取得
                     strForB = Mid(strFreeBusy, iTimeSlot, 1)
                     If strForB = "0" Then ' 0 なら空き
                         strForB = FREE_MARK
                     Else ' 0 以外なら予定あり
                         strForB = BUSY_MARK
                     End If
                     ' 該当セルに空き情報を設定
                     .Cells(iRow, START_COL + iDate * iTimeSpan + iHour) = strForB
                 Next
             Next
             ' 次の行へ移動
             iRow = iRow + 1
         Wend
     End With
End Sub

マクロの登録方法やメニューへの追加について