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

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

そんな中で悩むことは、

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

ではないでしょうか?

今回は、

・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 

    strEnd = DateAdd("d", 1, strEnd)   ' 1日追加 
     
    '対象ユーザが記載されているメアド分予定表取り込み処理を繰り返します。 
    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 
  
    
    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へ取り込まれていることが確認できましたね!

<追記>複数の他人のOutlook予定表をExcelへ取り込むVBA–時間指定バージョン

上記のVBAでは、期間指定の際、日付までの指定しかできない仕様であるので、
0時開始の“終日イベント”が抜け落ちてしまう場合がありました。

予定表の上部にでるアイテムが終日イベントとなります。

そこで、期間指定の日付に時間を加えて、終日イベントの抜け落ちを防ぎ、より詳細な期間指定ができるよう改良したものを公開したいと思います。

タカヒロ
タカヒロ
読者様より不具合とその対応までご教示いただきました。
ありがとうございます。

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("2021/1/1 00:00", "yyyy/mm/dd hh:nn") '抽出するスケジュールの開始日+時刻を指定
    strEnd = Format("2021/1/25 10:30", "yyyy/mm/dd hh:nn")   '抽出するスケジュールの終了日+時刻を指定
    
  
    '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 = "対象者(メアド)"
        .Cells(1, 12).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
  

    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
                wsSheet1.Cells(lnContactCount, 12).Value = .AllDayEvent

            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

変更した箇所は以下の通りです。

対象予定表の抽出期間の指定を日にちのみから日時へ変更するため、”yyyy/mm/dd hh:nn“のフォーマットとしました。

ですので、期間指定の際は”2021/1/1 00:00″のように時間を含むようにお願いします。

strStart = Format(“2021/1/1 00:00”, “yyyy/mm/dd hh:nn“) ‘抽出するスケジュールの開始日+時刻を指定
strEnd = Format(“2021/1/25 10:30”, “yyyy/mm/dd hh:nn“) ‘抽出するスケジュールの終了日+時刻を指定

また、終日イベントは0時始まりですので、抽出開始日に終日のイベントがある場合は「strStart」を0時から指定するようお願いします。

サンプルは、Outlookの予定表へ2021/1/1に終日のイベントをいれており、

前バージョンですと終日のイベントは抜け落ちますが、

このバージョンを実行すると、終日イベントが含まれていることが確認できました。

なお、終日のイベントであるかどうかを判断するために、

AllDayEventプロパティを取得するように追加をしています。

wsSheet1.Cells(lnContactCount, 12).Value = .AllDayEvent

AllDayEventプロパティが「True」の場合、終日イベントであるという判定となります。

取得した値を確認してみると、

True」になっていることが確認できましたね!

<追加>複数の他人のOutlook予定表を取り込む際に、特定の文字を含む件名のみに絞り込む方法

読者の方よりOutlook予定表を取り込む際に特定の文字を含む件名に絞り込む方法について質問がありましたので、

対応方法について追記いたします。

サンプルコードの以下箇所を変更します。

変更前

If olItem.Start >= strStart And olItem.End <= strEnd Then

変更後

If olItem.Start >= strStart And olItem.End < strEnd And olItem.Subject Like “*<ここに抽出したい文字を入力>*” Then

Like演算子と半角ワイルドカード「*」を使う方法です。

例えば「【重要】〇〇〇検討のこと」など「重要」を含む件名のみ抽出したい場合は、

If olItem.Start >= strStart And olItem.End < strEnd And olItem.Subject Like “*重要*” Then

のようにします。

タカヒロ
タカヒロ
ワイルドカードは全角では効かないので、かならず半角にしてください。

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

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

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

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

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

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("2021/1/1 00:00", "yyyy/mm/dd hh:nn") '抽出するスケジュールの開始日+時刻を指定
    strEnd = Format("2022/6/25 10:30", "yyyy/mm/dd hh:nn")   '抽出するスケジュールの終了日+時刻を指定
    
  
    '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 = "対象者(メアド)"
        .Cells(1, 12).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
  
     
    '処理速度優先のためスクリーンの更新は行われません。
    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
     
     
    'Restrictソッドで期間指定して抽出するスケジュールを絞り込みます。
    Set olConItems = olConItems.Restrict("[End] <= """ & strEnd & """ AND [Start] >= """ & strStart & """")
     
     
    For Each olItem In olConItems
    
        'Findで検索すると期間範囲外の余計なものまでヒットしてしまうので、再度フィルタリングします。
        If TypeName(olItem) = "AppointmentItem" 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
                wsSheet1.Cells(lnContactCount, 12).Value = .AllDayEvent

            End With
            lnContactCount = lnContactCount + 1
        End If

        Set olItem = olConItems.FindNext
        
    Next
    
     
    '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

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

'Restrictソッドで期間指定して抽出するスケジュールを絞り込みます。
Set olConItems = olConItems.Restrict("[End] <= """ & strEnd & """ AND [Start] >= """ & strStart & """")
For Each olItem In olConItems
・・・
Next

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

さいごに

いかがでしょうか。

今回は

・VBAで複数ユーザのOutlook予定表を一瞬でExcelへ取り込む方法
・オプションで期間指定や抽出文字条件を設定をする方法

についてまとめました。

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



この記事の関連キーワード

こちらの記事の関連キーワード一覧です。クリックするとキーワードに関連する記事一覧が閲覧できます。




タカヒロ

プログラミングやマーケティングなどに興味あるけど
どのスクールが良いか悩むときはないですか?

タカヒロもスクール選びにとても苦労しました…

そんな時には数ある中から第三者目線でいまの貴方に合ったスクールを提案してくれるスクマドのカウンセリングサービスがおすすめです。

メリットだけでなくディメリットもズバリと伝えてくれます!

これでお悩み時間を短縮できますね!詳細は☟になります。

※完全無料です。ご安心ください。





76 件のコメント

  • 先ほどの質問ですが、自己解決しましたので手順を公開させていただきます。お手数おかけしまして申し訳ございません。

    If olItem.Start >= strStart And olItem.End = strStart And olItem.End = strStart And olItem.End = strStart And olItem.End < strEnd And olItem.Subject Like “*<ここに抽出したい文字を入力2>*” Then

    不細工ですがこれで動きました。

  • 返信遅くなってしまって申し訳ありません。
    大変参考になりました、ありがとうございました!

    続けて恐縮ですが、もう一点変更したいところがございまして教えていただければ幸いでございます。

    以下のコードについてです。
    If olItem.Start >= strStart And olItem.End = strStart And olItem.End < strEnd And olItem.Subject Like “*<ここに抽出したい文字を入力>*” or Like “*<ここに抽出したい文字を入力2>*” Then

    このように変更したのですが構文エラーになってしまいました。
    よろしくお願いします。

  • タカヒロさん

    わかりやすい記事でとても参考になりました、ありがとうございます。

    ご教示いただきたいことが一点ございまして、質問させていただきたく思います。

    毎日その日の予定を取得しなければならないため、VBAを知らない人のためにもマクロを実行した日のメールを取得できるようにしたいです。

    どのように変更すればよいでしょうか?

    よろしくおねがいします。

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

      実行日を期間に指定する方法につきまして、
      Date関数を使用することによって可能です。

      変更する箇所は以下の通りです。

      ■変更前
      strStart = Format(“2021/1/1 00:00”, “yyyy/mm/dd hh:nn”) ‘抽出するスケジュールの開始日+時刻を指定
      strEnd = Format(“2021/1/25 10:30”, “yyyy/mm/dd hh:nn”) ‘抽出するスケジュールの終了日+時刻を指定

      ■変更後
      strStart = Format(Date, “yyyy/mm/dd hh:nn”) ‘抽出するスケジュールの開始日+時刻を指定
      strEnd = Format(Date + 1, “yyyy/mm/dd hh:nn”) ‘抽出するスケジュールの終了日+時刻を指定

      例えば、6月5日に実行した場合、
      開始日時は2022/06/05 00:00、終了日時は2022/06/06 00:00が変数に代入される形となります。

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

  • タカヒロさん
    アドバイス頂きありがとうございます。
    待機エラーの件ですが、エクセル上でOutlookサーバーにアクセスしてしばらく応答がなかった場合のエラーのようで、VBA内で以下のコードを先頭に追加することで対処することが出来ましたので、今後同じ内容でお困りの人が出てきたときのために記載させていただきます。
    ーーー
    On Error Resume Next ‘エラー無視開始
    Application.DisplayAlerts = False
    ーーー

    またエクセルのマクロを実行して、実行後に上書き保存して終了するシステムをVBSで実現しようとしています。

    マクロが単純な処理であれば正常にマクロが実行され上書き保存し終了することができることを確認できています。

    しかし処理時間のかかるマクロ(1時間程度)を実行した場合に、保存して終了するコード(mybook.close true )の箇所で”システムコールに失敗しました”というエラーが起きてしまい、正常に保存することが出来ませんでした。
    なにか対策方法があれば教えていただきたいです。
    VBSのコードは以下になります。

    ——–VBSコード——-
    dim xlApp,myBook
    ‘on error resume next
    set xlapp=createobject(“excel.application”)
    xlapp.visible=true
    set myBook=xlapp.workbooks.open(“ファイル名”)
    ‘↓のようにRUNでブック名とプロシージャ名を指定します。
    xlapp.run mybook.name & “!test1”
    ‘↓保存して閉じる場合はClose True です。
    mybook.close true
    set mybook=nothing
    xlapp.quit
    set xlApp=nothing
    ——————————

    • ご連絡ありがとうございます。

      待機エラーの件はサーバ側からのレスポンス不備が要因ということであれば
      一旦エラーを無視する形で処理は継続できるかと存じます。

      VBSで保存して終了する時にエラーとなる件ですが、再現はできないので憶測ですが、
      VBS側でVBAの処理終了が拾えていないことが要因かと思われますので、
      VBAの処理結果をVBSで確認するロジックを追加するか、
      VBA側で保存して終了する処理をするかをご検討いただければと存じます。

  • タカヒロさん
    ご見解いただきありがとうございます。
    利用者が少ない深夜帯に実行する、またスペックの高いPCで実施する、などの対策を行いましたがやはり100人を超えるとVBAが上手く走らず、「別のプログラムでOLEの操作が完了するまで待機します」という警告でストップしてしまいます。
    VBAのプログラムを修正することで対策になりそうなことがあればご教授いただきたいです。

    • 処理件数は50名から100名ほどに増えたけれど待機エラーになるのですね。

      あとVBA側でできることとなると、
      strStart/strEndで設定している抽出期間を短く設定し処理アイテム数を抑えるか、
      処理の間に数秒のWaitを入れ、参照先の負荷を軽減するかでしょうか。以下は例です。
      For n = 2 To wsSheet2.Cells(1048576, 1).End(xlUp).Row

      Application.Wait Now() + TimeValue(“00:00:07”)
      Next

      また特定ユーザーで処理が止まっているようでしたらそのユーザーを除外した上で確認頂きたくお願いいたします。

  • 先日以下の1,2の手順についてご質問させていただきましたが、
    無事自己解決に至りましたので、今後同じ内容でお困りの人が出てきたときのために記載させていただきます。

    ————質問手順—————
    1. 前回インポートしたスケジュールで、開始日時が昨日までのイベントはセルに残して今日以降のイベントの列を削除する。
    2.その後VBAを実行して、新たに昨日までのイベントが並んだ行の、次の行から今日~1週間後までのイベントを追加する。
    上記1,2の実現方法を知りたい。
    —————————-

    —-VBA実装コード—-
    Dim i As Long
    For i = Cells(Rows.Count, “A”).End(xlUp).Row To 2 Step -1
    If Range(“A” & i).Value >= Now Then
    wsSheet1.Rows(i).Delete
    End If
    Next i
    —————————-

    上記の件は無事解決したのですが、新たに動作に困りごとが出てきましたので
    アドバイスいただけると大変有難いです。

    ー困りごとーー
    現在300名程度のスケジュールのインポートを行うことを考えています。
    VBAを実行すると、しばらくして「別のプログラムでOLEの操作が完了するまで待機します」という警告が出てしまいます。
    そこでタスクマネージャーで確認してみると、Outlookのタスクが「応答なし」になっており、アプリケーションが応答していないため、このような警告が出てプログラムが停止してしまっていると考えられます。
    カットアンドトライで試してみたところ、50名程度までなら無事に動作しました。
    CPUのスペックの問題なのか、もしくはネットワーク環境の問題なのか分かりませんが、VBA側でなにか対策方法などあればアドバイスをいただけないでしょうか。
    ーーーーーーー

    ちなみに応答されずプログラムが停止している箇所をデバッグすると、以下の行で止まっていることが多かったです。
    Set olItem = olConItems.Find(“[End] = “”” & strStart & “”””)

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

    • ご連絡ありがとうございます。
      また解決内容の共有、大変ありがたく存じます。

      「別のプログラムでOLEの操作が完了するまで待機します」という警告が出てしまう件ですが、
      ご認識の通りOutlookの応答がなく、Excel側が待機になっている状態かと思われます。

      Outlookが実装されているPC側の問題の可能性がありますので、
      CPUやメモリが閾値を超えていないか、またバックグランド処理(ウイルススキャン)など走っていないかご確認いただけますでしょうか。

      次に可能性がある箇所は参照先のExchangeサーバ/Onlineとなり、同時接続数などのExchange側の制限に引っかかっている可能性があります。
      その場合には利用者が少ない時間帯に実行するなどご確認頂きたくお願いいたします。

  • ご丁寧な回答、誠にありがとうございました。
    無事、終日イベントかつ特定の文字列でスケジュールをインポートする事ができました。

    現在数百名程度のスケジュール(1ヶ月前~1週間後)を一括でインポートする必要があり、実行に数時間(3~4時間)かかってしまう状況です。そこで本VBAプログラムで実行速度を改善できる点や記述があれば、教えていただきたいです。

    また実行速度の関係から、過去のイベントはなるべくインポートしないように以下の動作を考えています。

    1. 前回インポートしたスケジュールで、開始日時が昨日までのイベントはセルに残して今日以降のイベントの列を削除する。

    2.その後VBAを実行して、新たに昨日までのイベントが並んだ行の、次の行から今日~1週間後までのイベントを追加する。

    この1~2の手順について、もし良ければどのように記述を変更すればよいか教えていただけますと大変助かります。

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

  • 非常にわかりやすい記事をありがとうございます。

    「終日イベント」かつ「特定の文字列が入ったイベント」からスケジュール検索を行い、エクセルに表示する方法を教えていただきたいです。

    以下の記述をどのように変更すればよろしいでしょうか。

    If olItem.Start >= strStart And olItem.End < strEnd And olItem.Subject Like “*○○*” Then

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

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

      「終日イベント」かつ「特定の文字列が入ったイベント」に絞り込む方法ですが、
      特定の文字の判定はLikeでよいかと思います。
      終日のイベントはAllDayEventプロパティにて判定ができますので、条件式を以下のように変更をしてください。
      If olItem.Start >= strStart And olItem.End < strEnd And olItem.Subject Like "*○○*" And olItem.AllDayEvent Then よろしくお願いいたします。

  • 返信遅くなりまして申し訳ありません。ご確認いただきありがとうございした。
    取得対象者を「すべての詳細を表示可能」に変更することが難しい状況です。
    (幹部クラスの人間の予定が含まれ、情報セキュリティ的にアウト)

    今後、折を見てアクセス許可レベル「タイトルと場所の表示が可能」の状況でも
    予定表を取得できることが出来た際には記事にしたいただければ幸いです。

    • ご連絡ありがとうございます。

      すべての参照権限を付与することが難しい状況であること承知いたしました。
      もし他の方法があるようでしたら追記させて頂きます。

  • 有益な情報をありがとうございます。
    ご質問ですが、予定表のアクセス許可レベルが「タイトルと場所の表示が可能」
    の人の予定表を取得することはできないでしょうか?
    件名、開始日時、終了日時、対象者(メアド)のみが必要で、前述のコメントを参考に出力する項目を絞り、自身の予定表を出力することはできましたグループ内の他人の予定を出力することが出来ませんでした。
    私の見落としで、既に回答済みの質問であればお手を煩わせて恐縮ですが、
    ご確認いただければ幸いです。

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

      「タイトルと場所の表示が可能」のアクセス権がある他人の予定表を出力できるかにつきまして、
      こちらでも検証しましたところ、予定表情報取得のところでエラーとなり、アイテムの取得はできない状況でした。

      推測ですが、VBAでは一旦全項目、全アイテムの予定表情報を取得する仕様であるため、アクセス権がない方(つまりタイトルと場所以外の項目)の権限が優先され、
      取得不可になったといったことが考えられます。

      ですので、お手数ではございますが、
      取得対象の予定表のアクセス権を「すべての詳細を表示可能」に設定いただければと存じます。

  • こんにちは
    大変参考になりました。

    大変初歩的な質問なのですが、
    strStart = Format(“2021/1/1 00:00”, “yyyy/mm/dd hh:nn”)
    strEnd = Format(“2021/1/25 10:30”, “yyyy/mm/dd hh:nn”)
    のところで、別シートのセルに日時を入力して
    開始日時をA1、終了日時をB1 としたいとき
    はどのように書き換えればいいのでしょうか?

    お手数をおかけしますがご教授いただけますと幸いです。
    よろしくお願いいたします。

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

      別シートにて開始日時、終了日時を指定する件ですが、
      別シート名を「Sheet4」、開始日時をA1、終了日時をB1 とする場合、
      strStart = Format(wbBook.Worksheets(“Sheet4”).Range(“A1”).Value, “yyyy/mm/dd hh:nn”)
      strEnd = Format(wbBook.Worksheets(“Sheet4”).Range(“B1”).Value, “yyyy/mm/dd hh:nn”)
      のようにして頂ければと存じます。

  • 非公開の予定の出力について、
    おかげ様で期待する動きを実現できました。
    ありがとうございます。非常に助かりました。

  • 連投失礼します。
    質問が誤っておりましたので、修正させて頂きます。

    ★非公開の予定はエクスポートしない。

    制御がややこしい場合は、当初の質問とおり下記を実現したいです。

    非公開の予定の場合は、下記の通りエクスポートしたいですが、
    どこをどう変更すれば実現できますでしょうか。
    ・件名「非公開」
    ・予定の本文「(空白)」
    教えてください。

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

      予定が非公開である場合の処理につきまして、Sensitivityプロパティにより判定が可能となります。

      Sensitivityプロパティは非公開の場合2(又はolPrivate)を持ちますので、
      非公開の予定をエクスポートさせない場合はSensitivityが2でないアイテムを出力する条件にします。

      具体的には以下のようにします。

      ■変更前
      If olItem.Start >= strStart And olItem.End <= strEnd Then

      ■変更後
      If olItem.Start >= strStart And olItem.End <= strEnd And Not olItem.Sensitivity = 2 Then

      また、
      ・件名「非公開」
      ・予定の本文「(空白)」
      とする場合は、同じく非公開判定の条件を加え件名、本文の出力処理を分ければよいです。
      If olItem.Sensitivity = 2 Then
      wsSheet1.Cells(lnContactCount, 1).Value = “非公開” ‘・件名「非公開」
      wsSheet1.Cells(lnContactCount, 5).Value = “” ‘・予定の本文「(空白)」
      Else
      wsSheet1.Cells(lnContactCount, 1).Value = .Subject
      wsSheet1.Cells(lnContactCount, 5).Value = .Body
      End If

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

  • 非公開の予定の場合は、下記の通りエクスポートしたいですが、
    どこをどう変更すれば実現できますでしょうか。
    ・件名「非公開」
    ・予定の本文「(空白)」
    教えてください。

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

      ご質問の終日の予定のみ&指定の文字を含む形で出力する方法ですが、
      コード内の条件式を以下のようにすることで対応可能です。

      ■変更前
      If olItem.Start >= strStart And olItem.End = strStart And olItem.End <= strEnd And olItem.AllDayEvent And InStr(olItem.Subject, “Test”) Then

      終日の予定を示すolItem.AllDayEventがTrueであり、かつ件名に”Test”が含まれる場合に対象となるような条件となります。
      “Test”の部分は用途に合わせて変更頂ければと思います。

      また件名ではなく本文内を部分一致させたい場合は「olItem.Subject」を「olItem.Body」へ変更してください。

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

  • コメントを残す

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