Outlookの予定表をExcelに取り込む

下記のVBAコードで、Outlookの予定表を、Excelに取り込むことができます

'Outlookのデータを取り込む
Sub OutlookAppointmentsToExcel()
  Dim olApp As Object
  Dim olNs As Object
  Dim olFolder As Object
  Dim olItems As Object
  Dim xlApp As Object
  Dim xlWb As Object
  Dim xlWs1 As Object
  Dim xlWs2 As Object
  Dim lastRow As Long
  Dim startDate As Date
  Dim endDate As Date
  Dim i As Long

'Outlookの予定表を取得する
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set olFolder = olNs.GetDefaultFolder(9) 'olFolderCalendar=9
Set olItems = olFolder.Items

'元のExcelブックを参照する
Set xlWb = ThisWorkbook
Set xlWs1 = xlWb.Sheets("取込")
Set xlWs2 = xlWb.Sheets("データ")
lastRow = xlWs2.Cells(xlWs2.Rows.Count, "A").End(-4162).Row + 0 '-4162=xltUp

'期間指定のための日付を「取込」シートのB3セルとB4セルから取得する
startDate = DateValue(xlWs1.Range("B3").Value) + TimeValue("00:00:00")
endDate = DateValue(xlWs1.Range("B4").Value) + TimeValue("23:59:59")

'予定表のデータをExcelに追記する
For i = 1 To olItems.Count
Dim olAppt As Object
Set olAppt = olItems(i)
If IsDate(olAppt.Start) Then '予定表の開始日時が日付である場合に処理を実行する
  If CDate(olAppt.Start) >= startDate And CDate(olAppt.End) <= endDate Then '指定した期間の予定表のみ追加する
   lastRow = lastRow + 1
    xlWs2.Cells(lastRow, 1).Value = olAppt.EntryID           'ID
    xlWs2.Cells(lastRow, 2).Value = olAppt.Start             '開始時刻
    xlWs2.Cells(lastRow, 3).Value = olAppt.End               '終了時刻
    xlWs2.Cells(lastRow, 4).Value = olAppt.Categories        '分類
    xlWs2.Cells(lastRow, 5).Value = olAppt.Subject           'タイトル
    xlWs2.Cells(lastRow, 6).Value = olAppt.Location          '場所
    xlWs2.Cells(lastRow, 7).Value = olAppt.Organizer         '登録者
    xlWs2.Cells(lastRow, 8).Value = olAppt.RequiredAttendees '必須出席者
    xlWs2.Cells(lastRow, 9).Value = olAppt.OptionalAttendees '任意出席者
    xlWs2.Cells(lastRow, 10).Value = olAppt.Body             '本文
    xlWs2.Cells(lastRow, 11).Value = olAppt.IsRecurring      '定期的な予定
    xlWs2.Cells(lastRow, 12).Value = olAppt.Resources        'リソース
    xlWs2.Cells(lastRow, 13).Value = olAppt.Sensitivity      '公開
    xlWs2.Cells(lastRow, 14).Value = olAppt.Importance       '重要度
  End If
End If
Next i

'オブジェクトを解放する
Set xlWs1 = Nothing
Set xlWs2 = Nothing
Set xlWb = Nothing
Set olItems = Nothing
Set olFolder = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub