Excel-Termin in Outlook-Kalender VBA

Private Sub CommandButton2_Click()
Dim olApp As Outlook.Application
Dim olAppt As Outlook.AppointmentItem
Dim olFldr As Outlook.MAPIFolder
Dim z As Long
Dim found As Boolean
For z = 1 To 16000
If ActiveSheet.Cells(z, 1).Value = "Ja" And ActiveSheet.Cells(z, 2).Value = "Test" Then
found = True
Set olApp = New Outlook.Application
Set olFldr = olApp.GetNamespace("MAPI").Folders.Item("Kalender.Test").Folders.Item("Kalender") _
Set olAppt = olFldr.Items.Add
With olAppt
.Start = Format(ActiveSheet.Cells(z, 6), "dd.mm.yyyy") & " 08:00"
.allDayEvent = True
.Subject = ActiveSheet.Cells(z, 5)
.Body = ActiveSheet.Cells(z, 9) & ", " & ActiveSheet.Cells(z, 12) & ", " &  _
ActiveSheet.Cells(z, 15)
.ReminderMinutesBeforeStart = 10
.categories = "Gelbe Kategorie"
.Save
End With
MsgBox "Termine wurden an Outlook übertragen.", , "Outlook"
ActiveSheet.Cells(z, 1).Value = "OK"
Exit For
End If
If Not found Then
MsgBox "Übertragung fehlgeschlagen.", , "Fehlgeschlagen"
End If
End Sub