こんにちは、くのへ@MasazaneKunoheです。

ツイッターで他の人の予定表をエクセルに転記したい、というご相談を頂きました。
でも、リンク先のコードを使っても上手く動かない、という話でした。

色々調べたところ、Outlookメールのサーバサービス「Exchanger」には権限の設定があり、その設定によって他の人の予定フォルダにGetSharedDefaultFolderではアクセスできないという事象があり、上手く動かないようです。

この問題を回避するコードを作成しました。
他の記事にはないレアなソリューションですよ。

エクセルに予定表を転記するコード

①こちらのコードをエクセルVBAにコピペしてください。
②エクセルVBAで参照設定でOutlook Objectを設定して下さい。（参考）
③Outlookを起動した状態で、エクセルにてこのコードを使用してください。（エクセルの下準備はコードの下の解説記事参照）

↓冒頭にこれをエクセルVBAに記載してください（sleep関数を使えるようにするための呪文です）

Option Explicit

#If Win64 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

↓これもエクセルVBAに記載して下さい。コード本体です。

Sub OtherSchedule()

Const GroupNumber = 1


'他の人の予定表を取得するマクロ
Dim olApp As Outlook.Application
Set olApp = New Outlook.Application

Dim olNameSpace As Object
Set olNameSpace = olApp.GetNamespace("MAPI")


'表示を予定表に変えるマクロ
Set olApp.ActiveExplorer.CurrentFolder = olNameSpace.GetDefaultFolder(olFolderCalendar)

'画面が予定表に切り替わるのを待つ
Do Until olApp.ActiveExplorer.CurrentFolder.DefaultItemType = olAppointmentItem
  Sleep 100
Loop

'objExplore＝「予定表」の画面にする
Dim objExplore As Object
Set objExplore = Outlook.Application.ActiveExplorer

'objExplore＝「予定表」の画面にする
Dim Menbers As Object '予定表グループの各メンバーコレクションのForEach用変数
Dim i As Integer: i = 2 '行制御用変数


'一度グループ内全員のチェックを外す
For Each Menbers In objExplore.NavigationPane.CurrentModule.NavigationGroups.Item(GroupNumber).NavigationFolders

  Menbers.IsSelected = False

Next Menbers

'ここからデータ抽出
For Each Menbers In objExplore.NavigationPane.CurrentModule.NavigationGroups.Item(GroupNumber).NavigationFolders

  '抽出対象者を選択し、予定表を表示させる
  Menbers.IsSelected = True
  
  '誰の予定表であるか出力
  Cells(i, 1) = Menbers.DisplayName
    
  '予定表の中の予定アイテムを一つずつ抽出し、予定データを抽出する
  Dim Schedule As Object
  For Each Schedule In objExplore.CurrentFolder.Items
    If Format(Schedule.Start, "yyyymmdd") = Format(Now(), "yyyymmdd") Then

      Cells(i, 2) = Schedule.Location
      Cells(i, 3) = Format(Schedule.Start, "yyyymmdd")
      Cells(i, 4) = Format(Schedule.Start, "hh:MM")
      Cells(i, 5) = Format(Schedule.End, "hh:MM")
      Cells(i, 6) = Schedule.Subject
      
      i = i + 1
    End If
  Next Schedule

  Menbers.IsSelected = False

Next Menbers

End Sub

＜エクセルの準備＞
エクセルにこう書いてください。
A1セル：担当者
B1セル：場所
C1セル：日程
D1セル：開始時間
E1セル：終了時間
F1セル：件名

＜Outlook下準備＞
Outlook側でも下準備が必要です。
予定表の画面の左下の予定表グループを作り、予定表を出力したい人を登録してください。

そして、コードの初めの方に「Const GroupNumber = 1」という部分があるので書き換えてください。
GroupNumberとは、Outlook予定表のここのことです。↓