Hallo,
mit folgendem Code erstelle ich ganztägige Geburtstagstermine im Outlook-Kalender.
Leider werden die Termine nicht auf jährliche Wiederholung eingestellt, sondern kommen immer wöchentlich.
Was kann ich tun?
Beispieldatei
2025-01-01 - Beschäftigten-Liste Geburtstage.xlsb (Größe: 21,56 KB / Downloads: 4)
mit folgendem Code erstelle ich ganztägige Geburtstagstermine im Outlook-Kalender.
Leider werden die Termine nicht auf jährliche Wiederholung eingestellt, sondern kommen immer wöchentlich.
Was kann ich tun?
Option Explicit
Sub AddBirthdaysToOutlook()
Dim OutlookApp As Object
Dim OutlookNamespace As Object
Dim CalendarFolder As Object
Dim BirthdayItem As Object
Dim RecurrencePattern As Object
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Dim birthdayDate As Date
' Setze das Arbeitsblatt (hier wird das aktive Blatt verwendet)
Set ws = ThisWorkbook.ActiveSheet
' Erstelle eine Instanz von Outlook
On Error Resume Next
Set OutlookApp = GetObject(Class:="Outlook.Application")
If Err.Number <> 0 Then
Set OutlookApp = CreateObject(Class:="Outlook.Application")
End If
On Error GoTo 0
' Zugriff auf den Kalenderordner
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set CalendarFolder = OutlookNamespace.GetDefaultFolder(9) ' 9 steht für den Kalender
' Bestimme die letzte Zeile mit Daten in Spalte B und C
lastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row
' Durchlaufe die Liste der Geburtstage
For i = 2 To lastRow ' Beginne bei 2, um die Überschrift zu überspringen
If IsDate(ws.Cells(i, "F").Value) Then
birthdayDate = ws.Cells(i, "F").Value
' Erstelle einen neuen Termin im Kalender
Set BirthdayItem = CalendarFolder.Items.Add(1) ' 1 steht für einen Termin
With BirthdayItem
.Subject = " * " & ws.Cells(i, "E").Value & " (" & Year(ws.Cells(i, "F").Value) & ")"
.Start = DateSerial(Year(Date), Month(birthdayDate), Day(birthdayDate))
.body = "Geburtstag"
.AllDayEvent = True
' Erstelle das Wiederholungsmuster für den Geburtstagstermin
Set RecurrencePattern = .GetRecurrencePattern()
With RecurrencePattern
.RecurrenceType = 1 ' Jährlich (olRecursYearly)
.Interval = 1 ' Alle Jahre (jährlich)
.PatternStartDate = DateSerial(Year(Date), Month(birthdayDate), Day(birthdayDate))
.PatternEndDate = DateSerial(Year(Date) + 10, Month(birthdayDate), Day(birthdayDate)) ' Optional: Enddatum für die Wiederholung festlegen (z.B. nach 10 Jahren)
End With
.Sensitivity = 2 ' Sensitivity auf privat setzen (olPrivate)
' .display
.Save
End With
Set BirthdayItem = Nothing
Set RecurrencePattern = Nothing
End If
Next i
MsgBox "Alle Geburtstage wurden erfolgreich zum Kalender hinzugefügt!", vbInformation
End SubVBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0
Beispieldatei
