Sub GeburtstageNachOutlook()
Dim zelle As Range
Dim olApp As Outlook.Application
Dim olGeb As Outlook.ContactItem
Dim TagMinusEins As Date
Set olApp = New Outlook.Application
For Each zelle In Range("A2:A3")
Set olGeb = olApp.CreateItem(olContactItem)
olGeb.Birthday = Format(zelle.Value, "dd.mm.yyyy")
olGeb.LastName = zelle.Offset(0, 1).Value
olGeb.FirstName = zelle.Offset(0, 2).Value
olGeb.Categories = jahrgang2015
olGeb.Save
TagMinusEins = DateAdd("d", -1, Format(zelle.Value, "dd.mm.yyyy"))
Set olRemind = olApp.CreateItem(olAppointmentItem)
olRemind.Subject = zelle.Offset(0, 3).Value
olRemind.Body = "Morgen Geburtstag von " & zelle.Offset(0, 2).Value & " " & zelle.Offset(0, 1).Value & " am " & zelle.Value
olRemind.ReminderPlaySound = True
olRemind.ReminderSet = True
olRemind.ReminderMinutesBeforeStart = 0
olRemind.BusyStatus = olFree
olRemind.Start = TagMinusEins & " 08:00"
Set olRP = olRemind.GetRecurrencePattern
olRP.RecurrenceType = olRecursYearly
olRP.StartTime = TagMinusEins & " 08:00"
olRP.EndTime = TagMinusEins & " 08:01"
olRP.NoEndDate = True
olRemind.Save
Next
End Sub