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

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

そんな中で悩むことは、

ではないでしょうか？

今回は、

についてまとめます！

タカヒロ

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

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

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

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

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

利用ケースとしては、

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

が想定されます。

タカヒロ

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

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

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

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

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

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

メンバリストに記載されているメールアドレスをキーにしてOutlook側の予定表を検索、取得し、Excelの空シートへ予定表が入力されるといった流れとなります。

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

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では、期間指定の際、日付までの指定しかできない仕様であるので、
０時開始の“終日イベント”が抜け落ちてしまう場合がありました。

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

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

タカヒロ

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

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予定表を取り込む際に特定の文字を含む件名に絞り込む方法について質問がありましたので、

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

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

変更前

変更後

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

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

のようにします。

タカヒロ

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

＜追加＞複数の他人の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

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

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

さいごに

いかがでしょうか。

今回は

についてまとめました。

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