【Excel VBA】先月、今月、翌月分のOutlook予定表データをワンクリックで取り込む

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

前回、「【Excel VBA】一瞬でExcelワークシートへOutlookの予定表を取り込む」をご紹介しましたが、

読者の方からボタンクリックで先月、今月（当月）、翌月と

Outlookの予定表が取り込められるようできないかとご要望がありましたので、

さっそく、その操作ができるように機能を追加してみたいと思います！

先月、今月（当月）、翌月の予定表をExcelへ出力する方法について

今回のOutlook予定表出力VBAの実装先は、これまでと同様出力結果を書き込む先のExcelブック側となります。

実行する度に、現在の日付を取得して、それを基点に当月、

マイナス1か月して先月、プラス１か月で翌月という形で算出しています。

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

①Excelブック(VBA)から現在の日付を取得、今月（当月）、先月、翌月を算出
②Excelブック(VBA) →　今月（当月）、先月、翌月の予定一覧ちょうだい　→ Outlook
③Excelブック ←　今月（当月）、先月、翌月の予定一覧を出すよ　← Outlook

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

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

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

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

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

以上です。

VBAを実装する

続いてVBAを実装します。

今回VBAは以下の通りとなります。

VBAは前回の「【Excel VBA】一瞬でExcelワークシートへOutlookの予定表を取り込む」をベースに、

先月、今月（当月）、翌月分の期間指定をできるよう機能を追加したものとなります。

Sub 先月のOutlook予定表を取り込む()
Call Outlookの予定表を取り込む(DateSerial(Year(Now), Month(Now) - 1, 1), DateSerial(Year(Now), Month(Now), 0))
End Sub


Sub 当月のOutlook予定表を取り込む()
Call Outlookの予定表を取り込む(DateSerial(Year(Now), Month(Now) - 0, 1), DateSerial(Year(Date), Month(Date) + 1, 0))
End Sub


Sub 翌月のOutlook予定表を取り込む()
Call Outlookの予定表を取り込む(DateSerial(Year(Now), Month(Now) + 1, 1), DateSerial(Year(Date), Month(Date) + 2, 0))
End Sub



Sub Outlookの予定表を取り込む(strDayStart As Date, strDayEnd As Date)

    'Outlook用の定義
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.Namespace
    Dim olFolder As Folder
    Dim olConItems As Outlook.Items
    Dim olItem  As AppointmentItem
    Dim oPattern
    
    'Excel用の定義
    Dim wbBook As Workbook
    Dim wsSheet As Worksheet
    
    Dim lnContactCount As Long
    
    
    'スクリーンの更新は行われません。
    Application.ScreenUpdating = False
    
    'Excelのブックとワークシートのオブジェクトを設定します。
    Set wbBook = ThisWorkbook
    Set wsSheet = wbBook.Worksheets(1)
    
    '書き込み先のセルを指定します。また1行目にタイトルを記述します。
    With wsSheet
        .Range("A3").CurrentRegion.Clear
        .Cells(2, 1).Value = "件名"
        .Cells(2, 2).Value = "場所"
        .Cells(2, 3).Value = "開始日時"
        .Cells(2, 4).Value = "終了日時"
        .Cells(2, 5).Value = "予定の本文"
        .Cells(2, 6).Value = "予約者"
        .Cells(2, 7).Value = "必須出席者"
        .Cells(2, 8).Value = "任意出席者"
        .Cells(2, 9).Value = "EntryID"
        .Cells(2, 10).Value = "IsRecurring"


        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 = 3
    
    Dim objAppt As AppointmentItem
    Dim strStart As String
    Dim strEnd As String
    
    strStart = Format(strDayStart, "yyyy/mm/dd") '抽出するスケジュールの開始日を指定
    strEnd = Format(strDayEnd, "yyyy/mm/dd")  '抽出するスケジュールの終了日を指定
    strEnd = DateAdd("d", 1, strEnd)   ' 1日追加
   
   '開始日でソート
   olConItems.Sort "[Start]"
   
   '定期的な予定を含む※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
            Set oPattern = Nothing
            
            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 strDayStart & "から" & strDayEnd & "のOutlook予定表の取り込みが完了しました！", vbInformation
End Sub

実装手順は以下の通りです。

今回はExcel側にこのVBAを実装します。

①Excelを新規に開き、「開発」タブをクリックし、「VisualBasic」をクリックします。
もしくはショートカットキー「Alt」＋「F11」でもOKです。

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

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

こちらで完了です。

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

マクロ実行にあたり、Outlook側の予定表に先月から翌月までの予定を入れるようにします。

おそらくほとんどの方が来月分までみっちり予定が組まれ、サンプル予定など不要と思いますが、

無い方は先月から翌月まで予定を入れるようにお願いします。

サンプルでは以下のように入れています。

VBAを実行するボタンを追加する

今回の目玉である、先月、今月（当月）、翌月の予定表を取得する

マクロを実行するボタンを追加しましょう。

ボタンぽちで一瞬で実行されるのでめちゃ便利です！

実装の仕方は、

リボンメニュ「開発」＞「挿入」＞「フォームコントロール」をクリックし、

右上のアイコンをクリックします。

ボタンが挿入されるので、ボタンを右クリックし「マクロの登録」を選択します。

マクロの登録ウインドウが出たら、まずは先月分マクロ「先月のOutlook予定表を取り込む」を選択して、

「OK」をクリックします。

配置が終わったらボタンを左に移動させます。

次に同じ操作を当月分、翌月分と実施します。

ボタンを新規に追加し、

当月分マクロは「当月のOutlook予定表を取り込む」のマクロ、

翌月分のボタンに「翌月のOutlook予定表を取り込む」のマクロ

を指定します。

当月のボタンは真ん中あたり、翌月のボタンは右端に配置してください。

ボタンからマクロを実行する

①先月分の予定表を取得します。「先月予定表」ボタンををクリックします。

②Excelのワークシートに先月分の予定表情報が書き込まれたら一旦完成です！

③今月（当月）分の予定表を取得します。「当月予定表」ボタンををクリックします。

④Excelのワークシートに今月（当月）分の予定表情報が書き込まれましたね。

⑤翌月分の予定表を取得します。「翌月予定表」ボタンををクリックします。

⑥Excelのワークシートに翌月分の予定表情報が書き込まれましたね！

今回のVBAについて説明

先月、今月（当月）、翌月の予定表をExcelへ出力するVBAについて説明します。

なお、上記説明の通り、前回の「【Excel VBA】一瞬でExcelワークシートへOutlookの予定表を取り込む」をベースにしていますので、Outlookの予定表を取り込むモジュールの説明はこちらの記事をご参照ください。

先月の日付情報をDateSerial関数を使って取得します。

まず先月の月初は
DateSerial(Year(Now), Month(Now) – 1, 1
で取得します。

Now関数は現在の日付でそれぞれ、年、月を取得し、その月から-1か月し、その月の1日目をしてします。

次に月末を取得します。

月末は月によって30日だったり31日だったりバラツキがありますので月初のような日付の指定ができません。

そこで、先月の月末を取得するにあたり、当月を取得し、その月から1日減算します。引数は0を指定します。

DateSerial(Year(Now), Month(Now), 0)

これで先月の月初と月末を取得できましたので、

「Outlookの予定表を取り込む」関数へ引数として受け渡し、Callします。

Sub 先月のOutlook予定表を取り込む()
Call Outlookの予定表を取り込む(DateSerial(Year(Now), Month(Now) – 1, 1), DateSerial(Year(Now), Month(Now), 0))
End Sub

先月と同じ要領で当月の月初、月末を計算し、「Outlookの予定表を取り込む」関数を呼び出します。

Sub 当月のOutlook予定表を取り込む()
Call Outlookの予定表を取り込む(DateSerial(Year(Now), Month(Now) – 0, 1), DateSerial(Year(Date), Month(Date) + 1, 0))
End Sub

翌月も同様です。
Sub 翌月のOutlook予定表を取り込む()
Call Outlookの予定表を取り込む(DateSerial(Year(Now), Month(Now) + 1, 1), DateSerial(Year(Date), Month(Date) + 2, 0))
End Sub

なお、先月、今月（当月）、翌月と3か月分まとめて取得したい場合は、以下のように指定すれば可能です。
Sub 先月から翌月のOutlook予定表を取り込む()
Call Outlookの予定表を取り込む(DateSerial(Year(Now), Month(Now) – 1, 1), DateSerial(Year(Date), Month(Date) + 2, 0))
End Sub

また、先々月や翌々月などさらに範囲を広げるには、Month(Now) の加減算をするだけでできます。
Sub先々月から翌々月のOutlook予定表を取り込む()
Call Outlookの予定表を取り込む(DateSerial(Year(Now), Month(Now) – 2, 1), DateSerial(Year(Date), Month(Date) + 3, 0))
End Sub

その値をシートのセルの値に指定すれば、セルの値を変更することにより期間指定を行うことも可能です。

さいごに

いかがでしょうか。

今回はボタン操作により先月、今月（当月）、翌月のOutlook予定表に登録されている予定をExcelへ出力する方法をご紹介しました。

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

Excelの予定一覧から自分のOutlookの予定表へ登録する方法

【VBA】一瞬でExcelワークシートからOutlookの予定表へスケジュールを登録する

Excelの予定一覧から他人のOutlook予定表を登録、編集する方法

【Excel VBA】他人のOutlook予定表をExcelから登録、編集する

他人のOutlook予定表をExcelワークシートへ取り込む方法

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