Excel Tabelle als Termine in Outlook

Sub Bday()
Dim myOLApp As Object
Dim myItem As Object
Dim myFolder As Object
Dim i As Long
Dim strSubject As String
Dim dStart As Date
Set myOLApp = CreateObject("Outlook.Application")
Set myFolder = myOLApp.GetNameSpace("MAPI").GetDefaultFolder(9)
With Worksheets("Geburtstage")
i = 2
Do While .Cells(i, 1).Value  ""
strSubject = .Cells(i, 3)
dStart = .Cells(i, 1).Value + .Cells(i, 2).Value
If Not AppointmentExists(myFolder, strSubject) Then
Set myItem = myOLApp.CreateItem(1)
With myItem
.Subject = strSubject
.Body = "Gratulieren nicht vergessen!"
.Location = "Storkower Straße 127 - 133"
.Start = dStart
.Duration = 10
.Alldayevent = True
If WorksheetFunction.Weekday(dStart, 2) = 1 Then
.ReminderMinutesBeforeStart = 4320
Else
.ReminderMinutesBeforeStart = 1440
End If
.ReminderPlaySound = True
.ReminderSet = True
.Save
End With
Else
Debug.Print strSubject & " existiert"
End If
i = i + 1
Loop
End With
MsgBox "Termine an Outlook übertragen!"
Set myFolder = Nothing
Set myOLApp = Nothing
End Sub
Private Function AppointmentExists(objFolder As Object, strSubject As String) As Boolean
Dim objItem As Object
AppointmentExists = True
For Each objItem In objFolder.Items
If objItem.Subject = strSubject Then Exit Function
Next
AppointmentExists = False
End Function