【OutlookVBA】Excelを使って予定を一括登録する方法【マクロ利用】

Sub 予定作成マクロ()
    ' エラーハンドリングの設定
    On Error GoTo ErrorHandler

    ' OutlookとExcelのアプリケーションオブジェクトを宣言
    Dim objOutlook As Outlook.Application
    Dim objExcel As Excel.Application
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim objApItem As Outlook.AppointmentItem

    ' Excelファイルのパス
    Dim strFile As String
    strFile = "C:\Users\ichimoku\OneDrive\デスクトップ\予定.xlsx"

    ' Excelオブジェクトを開く
    Set objExcel = New Excel.Application
    Set wb = objExcel.Workbooks.Open(strFile)
    Set ws = wb.Worksheets("Sheet1")

    ' Outlookオブジェクトを開く
    Set objOutlook = New Outlook.Application

    ' データの取り込み開始行
    Dim i As Long
    i = 2

    ' Excelのデータが空でない間、ループ
    Do Until ws.Cells(i, 1).Value = ""
        ' Outlookのアポイントメントアイテムを作成
        Set objApItem = objOutlook.CreateItem(olAppointmentItem)
        With objApItem
            .Subject = ws.Cells(i, 1).Value      ' 件名
            .Location = ws.Cells(i, 2).Value     ' 場所
            .Start = ws.Cells(i, 3).Value        ' 開始日時
            .End = ws.Cells(i, 4).Value          ' 終了日時
            .Body = ws.Cells(i, 5).Value         ' 本文
            .ReminderSet = True
            .ReminderMinutesBeforeStart = 60     ' 開始60分前にリマインダー設定
            .Save                                ' 保存
        End With
        i = i + 1
    Loop

    ' オブジェクトを閉じる
    wb.Close SaveChanges:=False
    objExcel.Quit
    Set ws = Nothing
    Set wb = Nothing
    Set objExcel = Nothing
    Set objOutlook = Nothing

    Exit Sub

ErrorHandler:
    ' エラーメッセージの表示
    MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical
    ' オブジェクトを閉じる
    If Not wb Is Nothing Then
        wb.Close SaveChanges:=False
    End If
    If Not objExcel Is Nothing Then
        objExcel.Quit
    End If
    Set ws = Nothing
    Set wb = Nothing
    Set objExcel = Nothing
    Set objOutlook = Nothing
End Sub