Mit Excel einen Termin in Outlook erzeugen

Sub createAppointments()
    On Error Resume Next
    Dim sheet As Worksheet, rngStart As Range, rngEnd As Range, cell As Range
    Set objOL = CreateObject("Outlook.Application")  
    Set objCal = objOL.Session.GetDefaultFolder(9)
    Set sheet = Worksheets(1)
    Set rngStart = sheet.Range("A2")  
    Set rngEnd = rngStart.End(xlDown)
    counter = 0
    For Each cell In sheet.Range(rngStart, rngEnd)
        strSubject = cell.Text
        strStartDate = cell.Offset(0, 1).Text
        strStartTime = cell.Offset(0, 2).Text
        strEndDate = cell.Offset(0, 3).Text
        strEndTime = cell.Offset(0, 4).Text
        boolAllDay = cell.Offset(0, 5).Value
        strCategory = cell.Offset(0, 6).Text
        strComment = cell.Offset(0, 7).Text
        
        'Eventuelles Duplikat des Termins finden ---------  
        Set allItems = objCal.items
        allItems.Sort "[Start]"  
        ' Ganztagestermin oder normaler Termin unterscheiden  
        If boolAllDay = True Then
            ' Filtere Termine nach Ganztagesevents zu dieser Zeit und dem Betreff  
            Set dupe_item = allItems.Restrict("[Start]=""" & Format(strStartDate, "ddddd hh:nn") & """ AND [END]= """ & Format(DateAdd("d", 1, DateValue(strEndDate)), "ddddd hh:nn") & """ AND [Subject] = '" & strSubject & "' AND [AllDayEvent] = True")  
        Else
            ' Filtere normale Termine zu dieser Zeit und dem Betreff  
            Set dupe_item = allItems.Restrict("[Start]=""" & Format(strStartDate & " " & strStartTime, "ddddd hh:nn") & """ AND [END]= """ & Format(strEndDate & " " & strEndTime, "ddddd hh:nn") & """ AND [Subject] = '" & strSubject & "' AND [AllDayEvent] = False")  
        End If
        ' hole den ersten passenden Termin wenn er exisitiert  
        Set itm = dupe_item.GetFirst

        If itm Is Nothing Then
            ' erstelle neuen Termin wenn kein Duplikat exisitert  
            Set olApp = objCal.items.Add(1)
        Else
            ' verwende den gefundenen Termin  
            Set olApp = itm
        End If
        '--------------------------  
        
        With olApp   
            .Subject = strSubject
            .ReminderSet = False
            If strCategory <> "" Then  
                .Categories = strCategory
            End If
            .Body = strComment
            If boolAllDay = True Then
                .AllDayEvent = True
                If IsDate(strStartDate) Then
                    .Start = DateValue(strStartDate)
                    .End = DateAdd("d", 1, DateValue(strStartDate))  
                    .Save
                    counter = counter + 1
                Else
                    MsgBox "Termin mit dem Betreff: '" & strSubject & "' in Zeile " & cell.Row & " hat ungültige oder fehlende Zeitangaben", vbExclamation  
                End If
            Else
                .AllDayEvent = False
                If IsDate(strStartDate) And IsDate(strEndDate) And IsDate(strStartTime) And IsDate(strEndTime) Then
                    .Start = DateValue(strStartDate) & " " & TimeValue(strStartTime)  
                    .End = DateValue(strEndDate) & " " & TimeValue(strEndTime)  
                    .Save
                    counter = counter + 1
                Else
                    MsgBox "Termin mit dem Betreff: '" & strSubject & "' in Zeile " & cell.Row & " hat ungültige oder fehlende Zeitangaben", vbExclamation  
                End If
            End If
        End With
        set olApp = Nothing
    Next
    Set objOL = Nothing
    MsgBox counter & " Termin(e) wurden erstellt!", vbInformation  
End Sub

set objCal = objOL.Session.Stores.Item("user@domain.de").getDefaultFolder(9)  

set objCal = objOL.Session.Stores.Item("Name des Stores").GetRootFolder.Folders.Item("user@domain.de")  

.Location = cell.Offset(0,7).Value