【Excel VBA】一瞬でExcelワークシートへOutlookの予定表を取り込む方法

Outlookの予定表に登録されている予定をExcelシートへ一覧表にしたいことはないでしょうか。

例えば月次集計で定例会実施件数など活動履歴を集計したいときなどです。

そんな時に悩むことは、

ですよね。

今回はそんなお悩みを解決する、

についてまとめます！

予定一覧をExcelへ出力するイメージ

今回のOutlook予定表を出力するVBAの実行イメージについて説明をします。

まずVBAの実装先は、出力結果を書き込む先のExcel側となります。

Excelブック側からVBAを実行し以下の流れで処理が行われます。

①Excelブック(VBA) →　予定一覧ちょうだい　→ Outlook
②Excelブック ←　予定一覧を出すよ　← Outlook

Excel側のVBAを実行すると、

ExcelのワークシートにOutlookの予定表情報が書き込まれます！

カンタンですね。

早速VBAを実装をして動かしてみましょう！

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

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

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

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

以上です。

VBAを実装する

続いてVBAを実装します。

今回VBAは以下の通りとなります。
なお、VBAは前回の「【Excel VBA】カンタン！Outlookの連絡先をExcelワークシートへ取り込む」をベースに、連絡先部分を予定表へ変更をおこなったものとなります。

Sub Outlookの予定表を取り込む()

    'Outlook用の定義
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.Namespace
    Dim olFolder As Folder
    Dim olConItems As Outlook.Items
    Dim olItem  As AppointmentItem
    
    'Excel用の定義
    Dim wbBook As Workbook
    Dim wsSheet As Worksheet
    
    Dim lnContactCount As Long
    
    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 = "任意出席者"

        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 olFolder = olNamespace.GetDefaultFolder(olFolderCalendar)
    Set olConItems = olFolder.Items
            
    '取得結果を記述する行番号を指定します。2行目のセルから開始されることになります。
    lnContactCount = 2
    
    For Each olItem In olConItems
    Debug.Print TypeName(olItem)
        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

            End With
            lnContactCount = lnContactCount + 1
        End If
    Next olItem
    
    'オブジェクトを解放します。
    Set olItem = Nothing
    Set olConItems = Nothing
    Set olFolder = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing

            
    'スクリーンの更新を再開します。
    Application.ScreenUpdating = True
    
    MsgBox "Outlook予定表の取り込みが完了しました！", vbInformation
    
End Sub

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

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

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

こちらで完了です。

VBAを実行する

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

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

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

今回のVBAについて説明

予定表のリストはolFolderCalendarというメンバーに格納されています。
コードではolItemオブジェクトのタイプ名が”AppointmentItem”だった場合に処理を進めるようにしています。

If TypeName(olItem) = “AppointmentItem” Then

また連絡先の項目はプロパティに格納されており、今回は以下の項目に絞っています。
件名：Subject
場所：Location
開始日時：Start
終了日時：End
予定の本文：Body
予約者：Organizer
必須出席者：RequiredAttendees
任意出席者：OptionalAttendees

予定表のすべて項目は以下となっていますので、必要に応じて取捨選択頂ければと思います。

【参考】AppointmentItem オブジェクト (Outlook)

追記：Find、FindNextメソッドで期間指定し、抽出する予定を絞り込む

前回連絡先出力の時にご紹介したFind、FindNextメソッドを利用して、抽出する予定を絞り込む機能を追加しましたので、追記いたします。

【Outlook VBA】Outlook連絡先をVBAのFindメソッドで検索してみよう

コードは以下の通りです。

Sub Outlookの予定表を取り込む_期間指定Ver()

    'Outlook用の定義
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.Namespace
    Dim olFolder As Folder
    Dim olConItems As Outlook.Items
    Dim olItem  As AppointmentItem
    
    'Excel用の定義
    Dim wbBook As Workbook
    Dim wsSheet As Worksheet
    
    Dim lnContactCount As Long
    
    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 = "任意出席者"

        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 olFolder = olNamespace.GetDefaultFolder(olFolderCalendar)
    Set olConItems = olFolder.Items
    
    '取得結果を記述する行番号を指定します。2行目のセルから開始されることになります。
    lnContactCount = 2
    
    Dim objAppt As AppointmentItem
    Dim strStart As String
    Dim strEnd As String
    
    strStart = Format("2019/09/16", "yyyy/mm/dd") '抽出する予定の開始日を指定
    strEnd = Format("2019/09/17", "yyyy/mm/dd")  '抽出する予定の終了日を指定
    strEnd = DateAdd("d", 1, strEnd)   ' 1日追加
    
    '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
            End With
            lnContactCount = lnContactCount + 1
        End If
        Set olItem = olConItems.FindNext
    Wend
    
    
    'オブジェクトを解放します。
    Set olItem = Nothing
    Set olConItems = Nothing
    Set olFolder = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
    
            
    'スクリーンの更新を再開します。
    Application.ScreenUpdating = True
    
    MsgBox "Outlook予定表の取り込みが完了しました！", vbInformation
    
End Sub

今回は2019/09/16～2019/09/17までを指定しました。
期間を変更する箇所は以下となります。

strStart = Format(“2019/09/16“, “yyyy/mm/dd”) ‘抽出する予定の開始日を指定
strEnd = Format(“2019/09/17“, “yyyy/mm/dd”) ‘抽出する予定の終了日を指定

VBAから「Outlookの予定表を取り込む_期間指定Ver」を指定し、実行してみましょう。

はい！絞り込めましたね。

やはり絞り込み機能はあったほうが良いです。

さいごに

いかがでしょうか。

今回は

についてまとめました。

まだまだ便利な方法がりますので、よろしければご参照頂ければと思います。