Termine verwaltet in Excel in Outlook Kalender schreiben

Mit folgendem VBA Code kann man in Excel erfasste Termine via Funktionsaufruf in einen Outlook Kalender schreiben.
Voraussetzung ist folgende Terminstruktur


--- BEGINN VBA Code ---

Public Function OutlookVerfuegbar() As String

' Prüfen ob Outlook vorhanden ist.
' Outlook installiert ? Welche Version ?
'
' Fehlerbehandlung
  On Error GoTo ErrHandler

  Dim oOutlook As Object
  Set oOutlook = CreateObject("Outlook.Application")
  OutlookAvail = oOutlook.Version
  Set oOutlook = Nothing
  On Error GoTo 0
  Exit Function

ErrHandler:
  OutlookVerfuegbar = ""
End Function

Sub TerminNachOutlook()

   Dim StartDatum As String
   Dim StartUhrzeit As String
   Dim Dauer As Long
   Dim Beschreibung As String
   Dim Nachricht As String
   Dim Ort As String
   Dim i As Integer

   
 'Tabellenstruktur, Spaltenbeschriftung in erster Zeile
 'StartDatum Format TT.MM.JJJJ
 'StartUhrzeit Format SS:MM
 'Dauer Ganzzahl in Minuten
 'Beschreibung Text
 'Nachricht Text
 'Ort Text

 
   ActiveSheet.Cells(1, 1).Activate
   'Spaltenbeschriftungen stehen in Zeile 1, Termine ab Zeile 2
 
   For i = 1 To ActiveSheet.UsedRange.Rows.Count
 
    If i > 1 Then 'Zeile 1 = Spaltenbeschriftungen überspringen
 
        With ActiveSheet
            StartDatum = .Cells(i, 1).Value
            StartUhrzeit = .Cells(i, 2).Text & ":00"
'            Debug.Print Format(StartDatum, "dd.mm.yyyy") & " " & StartUhrzeit
            Dauer = .Cells(i, 3).Value
            Beschreibung = .Cells(i, 4).Value
            Nachricht = .Cells(i, 5).Value
            Ort = .Cells(i, 6).Value
        End With
         
            'Nach Outlook
         
            TerminInOutlookAnlegen StartDatum, StartUhrzeit, Dauer, Beschreibung, Nachricht, Ort
'
    End If
 
 
    Next i 'nächste Zeile / Termin
 
End Sub

Public Function TerminInOutlookAnlegen(outDate As String, outStartTime As String, outDauer As Long, outSubject As String, outBody As String, outlocation As String) As Boolean

On Error GoTo ErrOutLook

'Hier beginnen die Termine
    Set OutApp = CreateObject("Outlook.Application")
    Set apptOutApp = OutApp.CreateItem(1) 'olAppointmentItem)
    With apptOutApp
        'Datum und Uhrzeit
        .Start = Format(outDate, "dd.mm.yyyy") & " " & outStartTime
       
        'Termininfo
        .Subject = outSubject

        .body = outBody
        .Location = outlocation '         'Ort
       
        .Duration = outDauer   ' 1 Stunde = 60, Dauer in Minuten
        'Erinnerung setzen in Outlook (hier inaktiv)
      '  .ReminderMinutesBeforeStart = 10
        .ReminderPlaySound = True
       
        'Erinnerung wiederholen
        .ReminderSet = True
       
        'Termin speichern
        .Save
    End With
   
    Set apptOutApp = Nothing
    Set OutApp = Nothing

    TerminInOutlookAnlegen = True
    MsgBox "Termin an Outlook übertragen."
   
Exit Function

ErrOutLook:
Set apptOutApp = Nothing
Set OutApp = Nothing
TerminInOutlookAnlegen = False
MsgBox "Termin konnte in Outlook nicht eingetragen werden.  Fehler:" & Err.Description

End Function


--- ENDE VBA Code ---