【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 

    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
    
    Debug.Print wsSheet2.Cells(n, 1).Value
    Debug.Print strStart
    Debug.Print strEnd
     
        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」になっていることが確認できましたね!



さいごに

いかがでしょうか。

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

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

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

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

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

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


30 件のコメント

  • いつも参考にさせていただいております。
    質問させてください。
    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が見つからないとなります。原因は分からないでしょうか?
      おそらくですが、指定期間における対象者の予定アイテムが存在しないか、参照権限がないか、別ドメインのユーザであるか
      のどちらかと思われますので、確認頂けますでしょうか。

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

  • 勤怠管理にてこちらを実践したかったのですが、、、上手くいかず。。
    VBA初心者です。教えていただけると幸いです。

    olConItems. Sort “[Start]”と Set olItem = olConItems.Find(“[End] = “”” & strStart & “”””)の〔Start〕〔End〕が不明なプロパティです。というエラーがでてしまいます。大変基本的な質問で申し訳ありませんが、ご教示お願い致します。

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

      取得した予定アイテムに“[Start]”、“[End]”が存在しないか、対象ユーザの詳細情報を取得できる権限がなく、情報を取得できていない可能性があります。

      まずはご自身のメールアドレスを指定の上、予定表の取得ができるかご確認頂けますでしょうか。

      • 参考にさせていただきました。ありがとうございます。
        VBA初心者なものでいろいろ教えていただきたいです。

        ①そのまま使うと後の人になるほどstrEndが増えていってしまうため、
        strEnd = DateAdd(“d”, 1, strEnd)を抽出期間指定の下に持ってきました。
        ↑適切ですか?

        ②予定表(シート1)のセルすべてを縮小表示にしたいです。
        With olItem
        ・・・
        End With
        の下に
        With wsSheet1.Range(“A2”, “Z1000”)
        .WrapText = False
        .ShrinkToFit = True
        End With
        を入れました。
        ↑もっとスマートにできないですかね?

        ③strStartの日の終日の予定がうまく取得できません。
        どのようにすればできますか?

        ④5分刻みのタイムスケジュールを
         取り込み対象者ごとに列を分けて作成したいです。
         (イメージはOutlookの予定表を日ごとではなく1人1列にした感じ)
         作成するマクロができるようであれば教えていただきたいです。
         追加で予定が入っているセルなり図形なりをクリックしたら、それに対応したシート1の予定表にジャンプできるなどの機能が付くとうれしいです。

        以上、質問ばかりで申し訳ございませんがご回答よろしくお願いいたします。

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

          下記ご回答させて頂きます。

          ①そのまま使うと後の人になるほどstrEndが増えていってしまうため、
          strEnd = DateAdd(“d”, 1, strEnd)を抽出期間指定の下に持ってきました。
          ↑適切ですか?
          →大変失礼しました!バグでしたね…
          はい、ご指定の方法で問題ございません。
          掲載しているVBAも修正いたします。

          ②予定表(シート1)のセルすべてを縮小表示にしたいです。
          With olItem
          ・・・
          End With
          の下に
          With wsSheet1.Range(“A2”, “Z1000”)
          .WrapText = False
          .ShrinkToFit = True
          End With
          を入れました。
          ↑もっとスマートにできないですかね?

          →少し乱暴かもしれませんが、
          Cells.Select ‘すべて選択
          Selection.ShrinkToFit = True ‘選択範囲を縮小表示設定
          でどうでしょうか。

          ③strStartの日の終日の予定がうまく取得できません。
          どのようにすればできますか?

          →終日の予定ですと時間帯が0:00-0:00となるので、はじかれてしまいますね…
          申し訳ないのですが、strStartを1日前に設定頂けますでしょうか。

          ④5分刻みのタイムスケジュールを
           取り込み対象者ごとに列を分けて作成したいです。
           (イメージはOutlookの予定表を日ごとではなく1人1列にした感じ)
           作成するマクロができるようであれば教えていただきたいです。
           →1列1スケジュールでしたら条件付き書式やピボットグラフでガントチャートのようなものはできるでしょうけど、
            複数のスケジュールとなると作り込まないと難しいかもしれません。
            少し検討してみて、実現できるようであれば記事にしたいと思います。

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

          • ご提案いただいた方法で終日の予定のみの分岐ができました。
            予定表の取り込みsubを複製して実装しましたが、
            If olItem.Start >= strStart And olItem.End <= strEnd And olItem.AllDayEvent Then
            では、すべての予定を取り込んで終日の予定か判定して出力するのですかね?
            エクセルのマクロではそのようにしかできないものだと割り切ります。
            処理速度は改善できないものの見やすさは格段に良くなりました。
            ありがとうございます!

          • 形になったようでよかったです!

            処理高速化についてですが、ご認識通りExchangeから予定情報をまるまる取り込む仕様なので、正直限界がある状況です…
            その中で行うとすれば、取得対象者を減らすか、期間を短くするか、Whileより若干高速なFindメソッドに抽出条件を寄せる(例:AND [AllDayEvent] = “”True””追加とか)方法でしょうか。
            ご検討ください。

          • 質問、要望ばかりで申し訳ございませんが、

            終日の予定のみを出力するようにできませんか?
            どこかにチェックボックスなどで選択できて、終日の予定のみにチェックすると参照も終日の予定のみになり、出力完了までが短くなるような仕様だとうれしいです。

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

            ③ですが、やはり時間指定があった方がより正確に情報が取得とれるのでよいですね。
            参考にさせて頂きます。

            終日の予定のみを出力ということですが、
             AllDayEvent Property
            で判定が可能です。
            値が”True”の場合終日アイテムということになりますので、
            If olItem.Start >= strStart And olItem.End <= strEnd And olItem.AllDayEvent Then のように設定してみてください。 チェックボックスですが、 1つ目のシートにチェックボックスコントロール(ActiveXのほう)を挿入しチェックありなしを If wsSheet1.CheckBox1 Then とかで判定し、上記条件を適用する処理にすればよいかと思います。

          • 返信ありがとうございます。

            ①修正ありがとうございます。

            ②ご提案ありがとうございます。
             Cells.Selectですべて選択できるんですね!

            ③ずっとstrEndが問題なんだと思っていました。Startが問題だったんですね!
             ヒントを元にいろいろいじってみたらうまくいきました。ありがとうございます。
            対象期間の指定を以下のように時間を含むようにし、
            抽出の絞り込みと再度フィルタリングを未満ではなく以下に修正したらうまくいきました。
            「 strStart =・・・, “yyyy/mm/dd hh:nn”)
            strEnd = ・・・, “yyyy/mm/dd hh:nn”) 」
            「[End] <= """ & strEnd
              olItem.End <= strEnd」

            ④予定の被りがあると考えると、どうしてもガントチャートのようにするしかないんですね・・・
            あるのかはわかりませんが、四角い図形を追加するようなマクロだと何となくうまくいきそうだと思いました。
            軽くご検討よろしくお願いいたします。

  • 利用させていただいてます。 ありがとうございます。
    160人ぐらいのアドレスで使用させていただいているのですが、100人前後でデバッグが起こってしまいます。
    初心者でなぜそうなってしまうのかわからず困ってしまいました。
    ご教示ただけるとありがたいです。 よろしくお願いいたします。

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

      おそらくですがデータ取得先のExchange側で負荷軽減等の目的で制限がかけられている可能性があります。

      朝一などExchange側が高負荷となっている時間帯を避けるか、アドレス情報を分割(160人とすれば80人づつ)し、

      2回以上に分けて実施頂きたくお願い致します。

  • いまいち理解できない現象が起こっています。
    出力結果を見てみると開始日時と終了日時が過去の予定が入っていました。
    自分なりに調査した結果ですが、
    ①件名(.Subject)空白
    ②定期的な予定で出力したい日時まで予定が入っている。
    の予定は開始日時と終了日時が定期的な予定の開始になってしまうようです。

    例)出力したい 2/12 – 2/13
      件名がない定期的な予定 2/1 -2/19まで休日を除く15件
      出力結果 2/1 – 2/1が2件

    この予定を出力完了後に削除するなどは、予定があったはずの場所が空欄になってしまうということなので対処法として考えたくないです。
    また、他人の予定なので件名を入れるという対処法も考えたくないです。
    ちゃんと出力できるようにできないですかね?

    • 件名空白の定期的な予定(平日設定)の場合、指定期間以外の予定が抽出されてしまう状況ということですが、
      こちらで同じ条件で試しましたが、問題はありませんでした。

      おそらくですが、Findメソッドだけで絞り込み、かつ定期的な予定を拾わない設定をしていませんでしょうか?
      以下の箇所を無効化すると、同じ事象(2021/2/1の定期的な予定のマスタのみ抽出)となりました。
      ‘If olItem.Start >= strStart And olItem.End <= strEnd Then 'End If 'olConItems.IncludeRecurrences = True 一度ご確認頂きたくお願いいたします。 なお、件名が空白であることは今回の事象と関係なさそうです。

      • 自分の予定で
        ①件名が空白
        ②定期的な予定
        を作成してテストしてみましたが再現しませんでした。
        しかし他人の予定では例外なく再現するため、
        ①、②に加えて
        ③他人の予定
        の条件も必要な可能性があります。

        取り急ぎ共有まで

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

          こちらでも他の人の予定へ①②の形式で登録し、取得してみましたが、
          事象の再現はできず、処理上の問題は見当たりませんでした。

          となると、対象者が登録した予定そのものに問題があるかもしれません。

      • 検証ありがとうございます。
        確認しましたが、どちらも記事に記載のコードから変更していなかったです。逆に定期的な予定を取得しない設定にすると、他の定期的な予定を含めて、問題の予定は出力されませんでした。
        自分で変更した部分をもう一度確認してみます。

  • いくつも質問をして申し訳ございませんが、
    予定の開始日~終了日の範囲が取得開始日~終了日の範囲に含まれている場合に、その予定を出力することは可能でしょうか?
    その際に出力結果を実際の予定範囲ではなく、取得範囲のみに限定(変換?)できたら、なおうれしいです。
    例)
    予定 2/22 ~ 2/25
    取得 2/24 ~ 2/26
    出力 2/24 ~ 2/25

    • ご質問ありがとうございます。

      定期的な予定(2/22 ~ 2/25の日次指定)を、取得期間2/24 ~ 2/26で抽出ということでしたら、
      strStart = Format(“2021/2/24 00:00”, “yyyy/mm/dd hh:nn”)
      strEnd = Format(“2021/2/27 00:00”, “yyyy/mm/dd hh:nn”)
      で行けると思います。

      ただ、前回ご質問頂いた他人かつ件名が空欄の定期的な予定の場合範囲外のものも含まれてしまう事象がありますので、
      もし同じ状態となりましたら、デバッグしてどのような日付データ(形式、タイムゾーンなどを含む)となっているか、
      ご確認頂きたくお願いいたします。

       

      • ご回答ありがとうございます。

        定期的な予定ではなく、
        1件の予定で開始日から終了日が日を跨いでいる場合です。
        不可能であれば諦めます。よろしくお願いします。

        前回の質問した件は削除という手段にしました。時間があればデバッグします。

        • 1件の予定で開始~終了が2/22 ~ 2/25となっているということですが、
          抽出期間を2/24 ~ 2/26とした場合、現在の仕様ですと範囲外と判断されてしまいますね…

          対策としては、もし予定の変更可能であれば予定を日ごとに分割し、設定してもらうか、
          抽出期間を2/22 ~ 2/26にし、いったん含める形にするとかでしょうか。

          当該予定の件数が多い場合は、VBAで日ごとに予定レコードを分割して出力する方法も考えられますが、
          この場合はOutlook側との整合性がとれない形になりますのであまりお勧めはしません。

  • 上記改良したコードをそのまま実行すると以下のエラーがでます。
    マクロをそこまで使いなれてませんが対処法をご教示いただけますと幸いです。
    よろしくお願いいたします。

    実行時エラー’214735267(80020009)’
    “Start”は不明なプロパティです。

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

      “Start”のプロパティに関するエラーですが、
      “Start”は予定アイテムの開始を表すプロパティとなりますので、
      エラーの原因としては以下が考えられます。
      ・登録されている予定がない
      ・存在しないユーザを指定している
      ・予定アイテムに“Start”プロパティが存在しない

      お手数ですが、ご自身のアドレス、予定がある最小限の期間にした上で実行頂き
      同じエラーが発生するかご確認頂けますでしょうか。

  • いつも参考にさせてもらっています。
    教えてほしい事があります。
    シート2のB列に、取得対象者の名前を入力し抽出シートにもメアド+名前を表示させたいです。
    名前毎に別シートに転記したい為です。
    よろしくお願いします。

  • 初心者の為、質問させて下さい。
    上記マクロに、抽出対象者の名前も同時に表示させたいです。
    シート2のA列にメアド、B列に名前を記入してあります。
    対象者毎に別シートに転記させたい為です。
    宜しくお願いします。

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

      メアド以外に名前も追記させる件につきまして、以下の方法で対応可能となっております。

      ・「対象者名」項目追加 ※.Cells(1, 11).Value = “対象者(メアド)” の下に入れてください。
      .Cells(1, 12).Value = “対象者名”

      ・引数に対象者名となるB列の値(.Cells(n, 2).Value)を追加
      Call 他人のOutlook予定表予定をExcelへ取り込む(.Cells(n, 1).Value, strStart, strEnd, .Cells(n, 2).Value)

      ・呼び出し先モジュールの引数に対象者名の変数(strAddressname As String)追加
      Sub 他人のOutlook予定表予定をExcelへ取り込む(strAddress As String, strStart As String, strEnd As String, strAddressname As String)

      ・抽出シートへ対象者名分追加 ※wsSheet1.Cells(lnContactCount, 11).Value = strAddressの下に入れてください。
      wsSheet1.Cells(lnContactCount, 12).Value = strAddressname

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

  • お世話なります。
    どうしても深夜時間などがExcelへエクスポートできなかったので、タイムゾーンで稼働時間を変更していたのですが、前述されている

    strStart= Format(“2021/2/24 00:00”, “yyyy/mm/dd hh:nn”)
    strEnd = Format(“2021/2/27 00:00”, “yyyy/mm/dd hh:nn”)

    でうまく動きました。
    ありがとうございます。

  • コメントを残す

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