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

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

そんな中で悩むことは、

・カンタンに複数のメンバのOutlook予定表を一覧化する方法はどれ?
・Excelにメンバの予定をまとめたいのだけど、Outlookからの一括取得の方法はなに?

ではないでしょうか?

今回は、
Excel VBAで複数ユーザのOutlook予定表を一瞬でExcelへ取り込む方法について
まとめます!

タカヒロ
タカヒロ
業務の見える化にもつなげられますね。



複数ユーザのOutlook予定表を一瞬でExcelへ取り込む方法について

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

読者の方から複数ユーザのOutlook予定情報をまとめて取得できないか

ご要望がありましたので、その操作ができるように機能を変更してみました。

利用ケースとしては、

中間管理職層の方やチームリーダが所属メンバのスケジュールを確認すること

が想定されます。

タカヒロ
タカヒロ
数名のメンバのスケジュールならどうにか把握はできそうですが、数十名となるとなかなか厳しいものがありますよね。

このツールを使えば、メンバが数十名だろうがワンクリックで対象者のスケジュールが一覧化できますし、

いわゆる業務の見える化や可視化といわれるものに貢献できるかなと思っています。

では機能の説明をしたいと思います。

今回のVBAの実装先は、これまでと同様Excelブック側となります。

Excel側に取得したいメンバリスト(メールアドレス)シート予定表が入る空のシートを用意し、

メンバリストに記載されているメールアドレスをキーにしてOutlook側の予定表を検索、取得し、

Excelの空シートへ予定表が入力されるといった流れとなります。

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予定表をExcelへ取り込む() 
  
    Dim strAddress As String 
    Dim strStart As String 
    Dim strEnd As String 
    Dim n As Integer 
  
    'Excelのブックとワークシートのオブジェクトを設定します。 
    Set wbBook = ThisWorkbook 
    Set wsSheet1 = wbBook.Worksheets(1) 
    Set wsSheet2 = wbBook.Worksheets(2) 
     
  
    '対象予定表の抽出期間を指定します。※変更する場合は以下の日付を変更してください。 
    strStart = Format("2020/09/1", "yyyy/mm/dd") '抽出するスケジュールの開始日を指定 
    strEnd = Format("2020/09/1", "yyyy/mm/dd") '抽出するスケジュールの終了日を指定 
     
  
    '1番目のシートの1行目にタイトルを記述します。 
    With wsSheet1 
        .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。 
        .Cells(1, 11).Value = "対象者(メアド)" 
         
        With .Range("A1:Z1") 
            .Font.Bold = True 
            .Font.ColorIndex = 10 
            .Font.Size = 11 
        End With 
    End With 
     
     
    '対象ユーザが記載されているメアド分予定表取り込み処理を繰り返します。 
    For n = 2 To wsSheet2.Cells(1048576, 1).End(xlUp).Row 
     
        With wsSheet2 
           Call 他人のOutlook予定表予定をExcelへ取り込む(.Cells(n, 1).Value, strStart, strEnd) 
        End With 
     
    Next 
     
    MsgBox "Outlook予定表の取り込みが完了しました!", vbInformation 
     
    'Null out the variables. 
    Set wbBook = Nothing 
    Set wsSheet1 = Nothing 
    Set wsSheet2 = Nothing 
     
End Sub 
  
  
  
Sub 他人のOutlook予定表予定をExcelへ取り込む(strAddress As String, strStart As String, strEnd As String) 
  
    '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 recOther As Recipient 
    Dim objAppt As AppointmentItem 
  
     
  
    strEnd = DateAdd("d", 1, strEnd)   ' 1日追加 
    
    Dim strDummy As String 
     
    '処理速度優先のためスクリーンの更新は行われません。 
    Application.ScreenUpdating = False 
     
  
     
    '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 
  
  
    'ブックおよび、1番目のシート情報を取得します。 
    Set wbBook = ThisWorkbook 
    Set wsSheet1 = wbBook.Worksheets(1) 
     
    '取得結果を記述する行番号を指定します。 
    lnContactCount = wsSheet1.Cells(1048576, 1).End(xlUp).Row + 1 
     
  
   '開始日でソートします。 
   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 
                wsSheet1.Cells(lnContactCount, 1).Value = .Subject 
                wsSheet1.Cells(lnContactCount, 2).Value = .Location 
                wsSheet1.Cells(lnContactCount, 3).Value = .Start 
                wsSheet1.Cells(lnContactCount, 4).Value = .End 
                wsSheet1.Cells(lnContactCount, 5).Value = .Body 
                wsSheet1.Cells(lnContactCount, 6).Value = .Organizer 
                wsSheet1.Cells(lnContactCount, 7).Value = .RequiredAttendees 
                wsSheet1.Cells(lnContactCount, 8).Value = .OptionalAttendees 
                wsSheet1.Cells(lnContactCount, 9).Value = .EntryID 
                wsSheet1.Cells(lnContactCount, 10).Value = .IsRecurring 
                wsSheet1.Cells(lnContactCount, 11).Value = strAddress 
            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 
    Set wbBook = Nothing 
    Set wsSheet1 = Nothing 
     
    'Turn screen updating back on. 
    Application.ScreenUpdating = True 
     
  
     
End Sub 

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

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

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

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

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

こちらで完了です。



テストデータを準備する

予定表取得対象者のメールアドレスをExcelへまとめる

今回のマクロはExcel側にまとめた予定表取得対象者のメールアドレスを読み込み、予定表を取得する処理となるため、

Excel側に予定表取得対象者のメールアドレスをまとめる必要があります。

まず、Excelに2つのシートを用意します。

シート名は何でもよいですが、必ず2つ目のシートにメールアドレスを入力してください。

入力開始位置はA2セルとなります。

タカヒロ
タカヒロ
大量に投入するとマクロの処理時間が長くなりますので、はじめは2~3名程度でテストし、徐々に増やすほうがよいでしょう。

なお、予定表取得対象者のメールアドレスですが、同じドメインに参加しているユーザのメールアドレス
マクロを実行する人は対象者の予定が参照できる権限を保持している必要がありますので、ご注意ください。

取得したい予定の期間を指定する

次に取得したい予定の期間を指定します。
サンプルでは開始日、終了日ともに2020/09/1となっていますので、
こちらを変更するようにお願いします。

strStart = Format(“2020/09/1“, “yyyy/mm/dd”) ‘抽出するスケジュールの開始日を指定
strEnd = Format(“2020/09/1“, “yyyy/mm/dd”) ‘抽出するスケジュールの終了日を指定

タカヒロ
タカヒロ
対象期間は1~3日が適正です。

こちらで、テストデータの準備は完了です。



VBAを実行する

ExcelからOutlook予定表の単体の予定を変更する

では早速VBAの実行をしてみましょう。

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

②「Outlook予定表の取り込みが完了しました!」が表示されたら完了です。

Outlook予定表がExcelへ取り込まれていることが確認できましたね!



さいごに

いかがでしょうか。

今回は
Excel VBAで複数ユーザのOutlook予定表を一瞬でExcelへ取り込む方法について
をご紹介しました。

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

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

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

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

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

4 件のコメント

  • いつも参考にさせていただいております。
    質問させてください。
    82行目にてstrEndに1日追加している処理はなぜ行うのでしょうか。

    • いつもご利用ありがとうございます。

      ご質問のstrEndに1日追加している理由ですが、
      抽出期間の終了日を判定するためとなります。

      期間の判定は116行目のFindで以下のようにしています。
      [End] < strEnd かつ [Start] >= strStart
      例えば開始日、終了日共に2020/9/1を指定した場合、
      開始日は2020/9/1、終了日は2020/9/2より前という形になります。

      なお、1日足さずに、[End] <= strEnd
      でもよいとおもいますが、開始日、終了日が同じ値の場合
      正確に判定してくれるかちょっと不安でしたので、
      上記のようにしたという背景もあります…

      よろしくお願いいたします。

  • ちょうどやりたいことが載っていたので助かりました!

    ただ、エクセルのセルに抜き出したい日にちを入れて、そのシートを参照する様にして使ってみたのですが、選択した最終日の終日の予定が出てきませんでした。
    終日の予定はその日の0:00から次の日の0:00までになっているようで、最終日(str End)に追加で時間(00:01)を入れることで、翌日の0時1分より前のデータとなって取得できました。

    あと、20人ほどためしてみたのですが、4人で途中でエラーが出ます。Startが見つからないとでて、その分をキャンセルしても次はEndが見つからないとなります。
    原因は分からないでしょうか?

    • いつもご利用ありがとうございます。
      またお役に立ててうれしく思います!

      >追加で時間(00:01)を入れることで、翌日の0時1分より前のデータとなって取得できました。
      ご教示ありがとうございます。やはり時間指定が確実ですね。今後の参考にさせて頂きます。

      >Startが見つからないとでて、その分をキャンセルしても次はEndが見つからないとなります。原因は分からないでしょうか?
      おそらくですが、指定期間における対象者の予定アイテムが存在しないか、参照権限がないか、別ドメインのユーザであるか
      のどちらかと思われますので、確認頂けますでしょうか。

      よろしくお願いいたします。

  • コメントを残す

    メールアドレスが公開されることはありません。 * が付いている欄は必須項目です