Taken aanmaken in Outlook via VBA in Excel

Sub Excel2Agenda()
    Set olAppl = CreateObject("Outlook.Application")
    i = 2

    Do Until Trim(Cells(i, 1).Value) = ""
        With olAppl.createitem(1)
            .Start = Cells(i, 1).Value
            .Body = Cells(i, 2).Value
            .Subject = Cells(i, 3).Value
            .Location = ""
            .Duration = 0
            .BusyStatus = 2
            .ReminderSet = True
            .ReminderMinutesBeforeStart = 720
            .Save
        End With
        i = i + 1
    Loop
    
    MsgBox "Afspraken gepland", vbInformation, "Plan afspraken"
End Sub

Private Sub CommandButton1_Click()

    Dim blnOutlookQuit As Boolean
    Dim lngRow As Long
    Dim objFolder As Object
    Dim objNamespace As Object
    Dim objOutlook As Object
    Dim objTask As Object

    On Error Resume Next
    Set objOutlook = GetObject(, "Outlook.Application")
    If objOutlook Is Nothing Then
        blnOutlookQuit = True
        Set objOutlook = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
    
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set objFolder = objNamespace.GetDefaultFolder(13)
    objFolder.Display    'laat folder zien anders foutmelding door remindertime

    With Worksheets(1)
        For lngRow = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
            If Cells(lngRow, 8).Value = vbNullString Then
                Set objTask = objOutlook.CreateItem(3)
                With objTask
                    .Subject = CStr(Cells(lngRow, 2).Value)
                    .StartDate = CDate(Cells(lngRow, 4).Value)
                    .DueDate = CDate(Cells(lngRow, 5).Value)
                    .ReminderSet = CBool(Cells(lngRow, 6).Value)    'true false
                    .ReminderTime = CDate(Cells(lngRow, 5).Value)    'date and time
                    .Body = CStr(Cells(lngRow, 3).Value)
                    .Save
                End With
                Cells(lngRow, 11).NumberFormat = "@"
                Cells(lngRow, 11).Value = Format(Now(), "yyyy-MM-dd hh:mm:ss")
            End If
        Next
    End With

    If blnOutlookQuit Then
        objOutlook.Quit
    End If

    Set objTask = Nothing
    Set objFolder = Nothing
    Set objNamespace = Nothing
    Set objOutlook = Nothing

End Sub