【Excel VBA】Outlookの他人の予定表をExcelシートへ取り込む方法

Outlookの予定表でスケジュール共有を行うことは多いかと思いますが、データ収集などの目的で他人が共有している予定の一覧を取得したいことはないでしょうか。

ただ、そんなときに悩むことは

ですよね。

今回は

についてまとめます！

他人のOutlook予定表の予定一覧をExcelシートへ出力するイメージ

他人のOutlook予定表の予定一覧をExcelシートへ出力するイメージについて説明をします。

今回のVBAの実装先は、Excelブック側となり、

以下の流れで処理が行われます。

Excel側のVBAに取得したい人のアドレスを指定し、ExcelからVBAを実行すると、

指定した人が共有している予定一覧がポンとExcelへ出力されます！

とても便利ですよね！

早速実装して使ってみましょう！！

Excel VBAからOutlookを操作するための下準備

①まずExcelを起動し、「開発」タブをクリックします。

②VBEの画面が開いたら、メニューから「ツール」>「参照設定」を選択します。

③「Microsoft Outlook XX.X Object Library」を探してチェックボックスにチェックし「OK」をクリックします。

以上です。

他人の予定表へサンプルの予定を登録する

続いてOutlookへサンプルの予定を登録します。

今回は、3点の予定を「hanako@extan.jp」の予定表へ登録しました。

2つは単体の予定で、3つ目は週次の定期的な予定となります。

定期的な予定は以下の設定となっています。

他人のOutlook予定表の予定一覧をExcelシートへ出力するVBA

他人のOutlook予定表の予定一覧をExcelシートへ出力するVBAをExcelのVisual Basic EditorへVBAを実装して使ってみましょう。

VBAコード

今回のVBAは「【Excel VBA】一瞬でExcelワークシートへOutlookの予定表を取り込む」をベースに、他人の予定表を取り込められるよう、さらに「定期的な予定」も含むよう改良したものです。

サンプルコードは以下の通りです。

Sub Outlookの他人の予定表をExcelへ取り込む()

    'Outlook用の定義
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.Namespace
    Dim olFolder As Outlook.Folder
    Dim olConItems As Outlook.Items
    Dim olItem  As AppointmentItem

    'Excel用の定義
    Dim wbBook As Workbook
    Dim wsSheet As Worksheet
    Dim lnContactCount As Long
    
    '他人予定表の定義
    Dim strAddress As String
    Dim recOther As Recipient
    Dim objAppt As AppointmentItem
    Dim strStart As String
    Dim strEnd As String
    
    '対象予定表のアドレスを指定※予定表を変更するときは以下のアドレスを変更してください。
    strAddress = "hanako@extan.jp"
    
    '対象予定表の抽出期間を指定します。※変更する場合は以下の日付を変更してください。
    strStart = Format("2020/09/1", "yyyy/mm/dd") '抽出するスケジュールの開始日を指定
    strEnd = Format("2020/09/30", "yyyy/mm/dd")  '抽出するスケジュールの終了日を指定
    
    strEnd = DateAdd("d", 1, strEnd)   ' 1日追加
   
    Dim strDummy As String
    
    '処理速度優先のためスクリーンの更新は行われません。
    Application.ScreenUpdating = False
    
    'Excelのブックとワークシートのオブジェクトを設定します。
    Set wbBook = ThisWorkbook
    Set wsSheet = wbBook.Worksheets(1)
    
    '書き込み先のセルを指定します。また1行目にタイトルを記述します。
    With wsSheet
        .Range("A1").CurrentRegion.Clear
        .Cells(1, 1).Value = "件名"
        .Cells(1, 2).Value = "場所"
        .Cells(1, 3).Value = "開始日時"
        .Cells(1, 4).Value = "終了日時"
        .Cells(1, 5).Value = "予定の本文"
        .Cells(1, 6).Value = "予約者"
        .Cells(1, 7).Value = "必須出席者"
        .Cells(1, 8).Value = "任意出席者"
        .Cells(1, 9).Value = "EntryID" '予定のID※編集時にキーとして使用します。
        .Cells(1, 10).Value = "定期的な予定"  '定期的な予定であるかのフラグ。定期的な予定はTrue。

        With .Range("A1:Z1")
            .Font.Bold = True
            .Font.ColorIndex = 10
            .Font.Size = 11
        End With
    End With
    
    wsSheet.Activate
    
    'Outlookオブジェクトを設定し、MAPI名前空間を介してOutlookの予定表を取得します。
    Set olApp = New Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")
    '他人のオブジェクトを指定し取得します。
    Set recOther = olNamespace.CreateRecipient(strAddress)
    '取得した他人のオブジェクトの内、予定表のみ絞り込み再取得します。
    Set olFolder = olNamespace.GetSharedDefaultFolder(recOther, olFolderCalendar)
    Set olConItems = olFolder.Items

    
    '取得結果を記述する行番号を指定します。2行目のセルから開始されることになります。
    lnContactCount = 2
    

   '開始日でソートします。
   olConItems.Sort "[Start]"
   
   'Trueで定期的な予定を含むようにします。※Falseであると定期的な予定は含まれません。
   olConItems.IncludeRecurrences = True
    
    'Findメソッドで期間指定して抽出するスケジュールを絞り込みます。
    Set olItem = olConItems.Find("[End] < """ & strEnd & """ AND [Start] >= """ & strStart & """")
    
    
    
    While TypeName(olItem) = "AppointmentItem"
        'Findで検索すると期間範囲外の余計なものまでヒットしてしまうので、再度フィルタリングします。
        If olItem.Start >= strStart And olItem.End < strEnd Then
            With olItem
                Cells(lnContactCount, 1).Value = .Subject
                Cells(lnContactCount, 2).Value = .Location
                Cells(lnContactCount, 3).Value = .Start
                Cells(lnContactCount, 4).Value = .End
                Cells(lnContactCount, 5).Value = .Body
                Cells(lnContactCount, 6).Value = .Organizer
                Cells(lnContactCount, 7).Value = .RequiredAttendees
                Cells(lnContactCount, 8).Value = .OptionalAttendees
                Cells(lnContactCount, 9).Value = .EntryID
                Cells(lnContactCount, 10).Value = .IsRecurring
            End With
            lnContactCount = lnContactCount + 1
        End If
        Set olItem = olConItems.FindNext
    Wend
    
    'Null out the variables.
    Set olItem = Nothing
    Set olConItems = Nothing
    Set olFolder = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
      
    'Turn screen updating back on.
    Application.ScreenUpdating = True
    
    MsgBox "Outlook予定表の取り込みが完了しました！", vbInformation
    
End Sub

VBAを設定する

変更頂きたい箇所は2点です。

誰の予定表を取得するか、メールアドレスを指定する

対象予定表のアドレスを指定してください。

取得する期間を指定する

対象予定表の抽出期間を指定します。※変更する場合は以下の日付を変更してください。

VBAを実装する

実装手順は以下の通りです。今回はExcel側にVBAを実装します。
①Excelを新規に開き、「開発」タブをクリックし、「VisualBasic」をクリックします。
もしくはショートカットキー「Alt」＋「F11」でもOKです。

②標準モジュールを追加します。
左ペインのVBAProjectを右クリックし、「挿入」、「標準モジュール」を選択します。

③右ペインのウインドウに上記のVBAを入力します。

こちらで完了です。

VBAを実行する

①「開発」タブの「VBA」をクリックし「Outlookの他人の予定表をExcelへ取り込む」を選択し、「実行」をクリックします。

②Excelのワークシートに書き込まれたら完成です！

なお、実行にあたり予定登録数が多い場合は処理に時間がかかることがありますのでご注意ください。

VBAについて説明

今回のVBAについて説明をします。

Outlookオブジェクトを設定し、MAPI名前空間を介してOutlookの予定表を取得します。

今回追加したところは、他人のオブジェクトを指定し取得する処理です。
strAddressは上記で設定した他人のアドレスが格納されています。

取得した他人のオブジェクトの内、予定表のみ絞り込み再取得します。
予定表のリストはolFolderCalendarというメンバーに格納されていますのでそれを指定しています。

コードではolItemオブジェクトのタイプ名が”AppointmentItem”だった場合に処理を進めるようにして今います。

開始日で昇順ソートします。

定期的な予定の出力形式を指定します。
Trueで定期的な予定を含むようにします。Falseであると定期的な予定は含まれません。

取得する予定表の項目は以下の通りです。

「【Excel VBA】一瞬でExcelワークシートへOutlookの予定表を取り込む」の時の項目から、EntryIDと定期的な予定の2点を追加しています。

「EntryID」とは予定のIDで、予定ごとに異なるユニークの値となります。今回は使いませんが、次回編集時にキーとして使用します。

「定期的な予定」は定期的な予定であるかのフラグで定期的な予定はTrue、そうでない場合はFalseとなります。

＜追加＞他人のOutlook予定表を大量に取り込む際に、高速に処理する方法

Outlook予定表を大量に取り込む際にFindメソッドで失敗する例がありますので、その対処法について説明をします。

MSのリファレンスでは、Findメソッドはアイテム数が少ない場合処理は早いが、
アイテム数が多い場合はRestrictメソッドのほうが早くなると記載があります。
https://docs.microsoft.com/ja-jp/office/vba/api/outlook.items.restrict

ですので、Findメソッドで処理落ちする事象を解決する方法はRestrictメソッドに置き換えることで解消される可能性があります。

以下サンプルコードです。

Sub Outlookの他人の予定表をExcelへ取り込む_大量アイテム処理高速版()

    'Outlook用の定義
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.Namespace
    Dim olFolder As Outlook.Folder
    Dim olConItems As Outlook.Items
    Dim olItem  As AppointmentItem

    'Excel用の定義
    Dim wbBook As Workbook
    Dim wsSheet As Worksheet
    Dim lnContactCount As Long
    
    '他人予定表の定義
    Dim strAddress As String
    Dim recOther As Recipient
    Dim objAppt As AppointmentItem
    Dim strStart As String
    Dim strEnd As String
    
    '対象予定表のアドレスを指定※予定表を変更するときは以下のアドレスを変更してください。
    strAddress = "hanako@extan.jp"
    
    '対象予定表の抽出期間を指定します。※変更する場合は以下の日付を変更してください。
    strStart = Format("2021/1/1 00:00", "yyyy/mm/dd hh:nn") '抽出するスケジュールの開始日+時刻を指定
    strEnd = Format("2022/6/25 10:30", "yyyy/mm/dd hh:nn")   '抽出するスケジュールの終了日+時刻を指定

    
    '処理速度優先のためスクリーンの更新は行われません。
    Application.ScreenUpdating = False
    
    'Excelのブックとワークシートのオブジェクトを設定します。
    Set wbBook = ThisWorkbook
    Set wsSheet = wbBook.Worksheets(1)
    
    '書き込み先のセルを指定します。また1行目にタイトルを記述します。
    With wsSheet
        .Range("A1").CurrentRegion.Clear
        .Cells(1, 1).Value = "件名"
        .Cells(1, 2).Value = "場所"
        .Cells(1, 3).Value = "開始日時"
        .Cells(1, 4).Value = "終了日時"
        .Cells(1, 5).Value = "予定の本文"
        .Cells(1, 6).Value = "予約者"
        .Cells(1, 7).Value = "必須出席者"
        .Cells(1, 8).Value = "任意出席者"
        .Cells(1, 9).Value = "EntryID" '予定のID※編集時にキーとして使用します。
        .Cells(1, 10).Value = "定期的な予定"  '定期的な予定であるかのフラグ。定期的な予定はTrue。

        With .Range("A1:Z1")
            .Font.Bold = True
            .Font.ColorIndex = 10
            .Font.Size = 11
        End With
    End With
    
    wsSheet.Activate
    
    'Outlookオブジェクトを設定し、MAPI名前空間を介してOutlookの予定表を取得します。
    Set olApp = New Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")
    '他人のオブジェクトを指定し取得します。
    Set recOther = olNamespace.CreateRecipient(strAddress)
    '取得した他人のオブジェクトの内、予定表のみ絞り込み再取得します。
    Set olFolder = olNamespace.GetSharedDefaultFolder(recOther, olFolderCalendar)
    Set olConItems = olFolder.Items

    
    '取得結果を記述する行番号を指定します。2行目のセルから開始されることになります。
    lnContactCount = 2
    
   '開始日でソートします。
   olConItems.Sort "[Start]"
   
   'Trueで定期的な予定を含むようにします。※Falseであると定期的な予定は含まれません。
   olConItems.IncludeRecurrences = True
    
    'Restrictメソッドで期間指定して抽出するスケジュールを絞り込みます。
    'Set olItem = olConItems.Find("[End] < """ & strEnd & """ AND [Start] >= """ & strStart & """")
    Set olConItems = olConItems.Restrict("[End] <= """ & strEnd & """ AND [Start] >= """ & strStart & """")
    
    For Each olItem In olConItems
        If TypeName(olItem) = "AppointmentItem" Then
            With olItem
                Cells(lnContactCount, 1).Value = .Subject
                Cells(lnContactCount, 2).Value = .Location
                Cells(lnContactCount, 3).Value = .Start
                Cells(lnContactCount, 4).Value = .End
                Cells(lnContactCount, 5).Value = .Body
                Cells(lnContactCount, 6).Value = .Organizer
                Cells(lnContactCount, 7).Value = .RequiredAttendees
                Cells(lnContactCount, 8).Value = .OptionalAttendees
                Cells(lnContactCount, 9).Value = .EntryID
                Cells(lnContactCount, 10).Value = .IsRecurring
            End With
            lnContactCount = lnContactCount + 1
        End If
    Next
    
    'オブジェクトを解放します。
    Set olItem = Nothing
    Set olConItems = Nothing
    Set olFolder = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
      
    'スクリーンの更新をオンにします。
    Application.ScreenUpdating = True
    
    MsgBox "Outlook予定表の取り込みが完了しました！", vbInformation
    
End Sub

変更箇所は以下となります。

FindメソッドとWhile処理のところををRestrictソッドとFor Each処理へ置き換えています。

さいごに

いかがでしょうか。

今回は、

についてまとめました。

今回のVBAで他人の予定表を効率よく把握できるので、ぜひ活用いただければと思います。

タカヒロ

複数ユーザーのOutlook予定表をExcelへ取り込みたい場合はこちらをご参照ください。

【VBA】一瞬で複数ユーザのOutlook予定表をExcelへ取り込む方法！