![見出し画像](https://assets.st-note.com/production/uploads/images/139384616/rectangle_large_type_2_5044e787091037e9388b041df6385e10.png?width=1200)
Photo by
golchiki
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
この記事が気に入ったらサポートをしてみませんか?