Excel Makro->festen Termin an Outlook

Sub Termin_in_Outlook()
'E 2000
'Dim OutApp As Outlook.Application
Dim OutApp As Object, apptOutApp As Object
'Hier beginnen die Termine
Range("A37").Select
Do Until ActiveCell.Value = ""
Set OutApp = CreateObject("Outlook.Application")
Set apptOutApp = OutApp.CreateItem(1) 'olAppointmentItem)
With apptOutApp
.Start = ActiveCell.Offset(0, 0)
'Hier wird der Beginn-Datum eingegeben
.Subject = ActiveCell.Offset(0, 1)
'Hier wird der Betreff eingegeben
.ReminderSet = True
'Termin speichern
.Save
End With
'Nächste Zelle auswählen
ActiveCell.Offset(1, 0).Select
'Variablen leeren,... sonst ist Outlook irgendwann überlastet
Set apptOutApp = Nothing
Set OutApp = Nothing
Loop
MsgBox "Termine an Outlook übertragen!"
Range("B3").Select
End Sub