Erinnerung via Excel

Die Excel schaut so aus:
A               B       C       D          E
(Lieferant)	Thema	Umfang	Erinnerung
xy 	        xy      xy	06.02.18   8:00 Uhr

Option Explicit
Sub Termine_von_Excel_nach_Outlook_exportieren()
Dim outapp As Object, apptoutapp As Object
'Deklarationen
'Termine aus Excel-Sheet lesen
Range("A2").Select
'Mit Zelle "D2" beginnen
Do Until ActiveCell.Value = ""
'Wiederhole solange bis eine Zelle in Spalte A leer ist
If ActiveCell.Offset(0, 10).Value = "x" Then GoTo TerminDa
'Prüfen ob in Spalte 11 ein x ist,
'dass bedeutet, dass der Termin schon einmal erfasst wurde
'Wenn ein x vorhanden ist, dann zur Sprungmarke Termin da gehen
Set outapp = CreateObject("Outlook.Application")
Set apptoutapp = outapp.CreateItem(1)
With apptoutapp
'Termine werden ab hier aus den Zellen gelesen
If ActiveCell.Offset(0, 1).Value = "" Then
' Wenn keine Startzeit eingetragen ist dann
.Start = Format(ActiveCell.Value, "dd.mm.yyyy")
'Starttermin = Datum der aktiven Zelle
.AllDayEvent = True
'Ganztagsevent = Wahr
Else
'oder
.Start = Format(ActiveCell.Value, "dd.mm.yyyy") & " " & _
Format(ActiveCell.Offset(0, 1).Value, "hh:mm")
'Starttermin = Datum der aktiven Zelle & " " &
'              Uhrzeit der Zelle rechts neben der aktiven Zelle
.End = Format(ActiveCell.Offset(0, 4), "dd.mm.yyyy") & " " & _
Format(ActiveCell.Offset(0, 5).Value, "hh:mm")
'Endtermin = Datum der 4. Zelle neben der aktiven Zelle & " " &
'            Uhrzeit der 5. Zelle rechts neben der aktiven Zelle
End If
'Ende der Wennprüfung
.Subject = ActiveCell.Offset(0, 2).Value
'Terminbezeichnung
.Body = ""
'Zusätzlicher Text
.Location = ActiveCell.Offset(0, 3).Value
'Ort
'.Duration = ActiveCell.Offset(0, 4).Value
'Dauer des Ereignisses
If ActiveCell.Offset(0, 6).Value  "" Then
Range("A" & Range("A65536").End(xlUp).Row + 1).Value = Format(ActiveCell.Offset(0, 6).Value, _
_
"dd.mm.yyyy")
Range("B" & Range("A65536").End(xlUp).Row).Value = Format(ActiveCell.Offset(0, 7).Value, "  _
_
hh:mm")
If ActiveCell.Offset(0, 6).Value > ActiveCell.Value Then
Range("C" & Range("A65536").End(xlUp).Row).Value = "Errinnerung Ende '" & ActiveCell. _
Offset(0, 2).Value & _
" am " & ActiveCell.Offset(0, 4). _
Value & "'"
Else
Range("C" & Range("A65536").End(xlUp).Row).Value = "Errinnerung: '" & ActiveCell.Offset( _
_
0, 2).Value & _
" am " & ActiveCell.Value & "'"
End If
Range("E" & Range("A65536").End(xlUp).Row).Value = Format(ActiveCell.Offset(0, 6).Value, "  _
_
dd.mm.yyyy")
Range("F" & Range("A65536").End(xlUp).Row).Value = Format(ActiveCell.Offset(0, 7).Value, "  _
_
hh:mm")
Range("I" & Range("A65536").End(xlUp).Row).Value = "Ja"
End If
If ActiveCell.Offset(0, 8).Value = "Ja" Then
.ReminderSet = True
'Erinnerung einstellen
.ReminderMinutesBeforeStart = ActiveCell.Offset(0, 9)
'Erinnerung: 0 Minuten vor Ereignis
.ReminderPlaySound = True
'Erinnerungsfunktion mit Sound
End If
.Save
'Termin speichern
.display
'Termin anzeigen
End With
ActiveCell.Offset(0, 10).Value = "x"
' In die 11. Spalte ein x setzen heißt:
' der Termin wurde schon einmal in den Kalender eingetragen
' Deshalb den Code ab hier weiter abarbeiten
TerminDa:
'Sprungmarke
ActiveCell.Offset(1, 0).Select
'Nächste Zeile der gleichen Spalte auswählen
Set apptoutapp = Nothing
Set outapp = Nothing
Loop
'Nächster Schleifendurchlauf
MsgBox "Termine wurden in den Outlook Kalender übertragen!"
End Sub