lerone / gist:bdfc82dd4da44f39a93555dd574d5f25

' Serien-Kalendereinträge aus Excel erstellen mit Serienlogik, Löschung alter Einträge und Logging Sub SerienKalendereintraegeErstellen() Dim olApp As Object, olNS As Object Dim allCalendars As Collection, selectedCalendar As Object Dim calendarNames() As String, selectedIndex As Variant Dim olItems As Object, ws As Worksheet Dim lastRow As Long, i As Long, j As Long Dim eintraege As Collection Dim datum As Date, startzeit As Date, endzeit As Date Dim produkt As String, hinweis As String, veranstaltungsnummer As String Dim titel As String, ort As String Dim alreadyProcessed() As Boolean ' Outlook vorbereiten On Error Resume Next Set olApp = GetObject(, "Outlook.Application") If olApp Is Nothing Then Set olApp = CreateObject("Outlook.Application") On Error GoTo 0 If olApp Is Nothing Then MsgBox "Outlook konnte nicht gestartet werden.", vbCritical Exit Sub End If Set olNS = olApp.GetNamespace("MAPI") Set allCalendars = New Collection ' Kalender sammeln Dim store As Object, folder As Object For Each store In olNS.Folders For Each folder In store.Folders If folder.DefaultItemType = 1 Then allCalendars.Add folder Next folder Next store ' Kalenderauswahl ReDim calendarNames(1 To allCalendars.Count) For i = 1 To allCalendars.Count calendarNames(i) = allCalendars(i).Parent.Name & " – " & allCalendars(i).Name Next i selectedIndex = Application.InputBox("Wähle den Zielkalender aus (Zahl):" & vbCrLf & Join(calendarNames, vbCrLf), "Kalenderauswahl", Type:=1) If Not IsNumeric(selectedIndex) Or selectedIndex < 1 Or selectedIndex > allCalendars.Count Then Exit Sub Set selectedCalendar = allCalendars(selectedIndex) Set olItems = selectedCalendar.Items olItems.IncludeRecurrences = True olItems.Sort "[Start]" Set ws = ThisWorkbook.Sheets(1) lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row ReDim alreadyProcessed(1 To lastRow) ' Durch Einträge iterieren For i = 2 To lastRow If alreadyProcessed(i) Then GoTo Weiter ' Zeile validieren If Not IsDate(ws.Cells(i, "B").Value) Or ws.Cells(i, "G").Value = "" Then ws.Cells(i, "M").Value = "übersprungen (kein Datum/kein Produkt)" GoTo Weiter End If Set eintraege = New Collection veranstaltungsnummer = Trim(ws.Cells(i, "F").Value) produkt = Trim(ws.Cells(i, "G").Value) hinweis = Trim(ws.Cells(i, "L").Value) If InStr(hinweis, "Lehrgang: ") > 0 Then hinweis = Mid(hinweis, InStr(hinweis, "Lehrgang: ") + 10) End If titel = produkt & " - " & hinweis ort = ws.Cells(i, "J").Value ' Serie erkennen datum = ws.Cells(i, "B").Value eintraege.Add i alreadyProcessed(i) = True For j = i + 1 To lastRow If alreadyProcessed(j) Then GoTo SkipJ If Trim(ws.Cells(j, "F").Value) <> veranstaltungsnummer Then GoTo SkipJ If ws.Cells(j, "G").Value = "" Then GoTo SkipJ If Not IsDate(ws.Cells(j, "B").Value) Then GoTo SkipJ If ws.Cells(j, "B").Value - datum = 1 Or _ (Weekday(datum, vbMonday) = 5 And ws.Cells(j, "B").Value - datum = 3) Then eintraege.Add j alreadyProcessed(j) = True datum = ws.Cells(j, "B").Value Else Exit For End If SkipJ: Next j If eintraege.Count = 1 Then ' Einzeltermin Dim idx As Long: idx = eintraege(1) startzeit = ws.Cells(idx, "C").Value endzeit = ws.Cells(idx, "D").Value datum = ws.Cells(idx, "B").Value Call OutlookEintragErstellen(olItems, datum, startzeit, endzeit, titel, ort, veranstaltungsnummer) ws.Cells(idx, "M").Value = titel Else ' Alte Einzeltermine löschen For Each idx In eintraege datum = ws.Cells(idx, "B").Value Call OutlookEintragLoeschen(olItems, datum, titel) Next idx ' Serientermin Dim appt As Object Set appt = selectedCalendar.Items.Add With appt .Start = ws.Cells(eintraege(1), "B").Value + ws.Cells(eintraege(1), "C").Value .End = ws.Cells(eintraege(1), "B").Value + ws.Cells(eintraege(1), "D").Value .Subject = titel .Location = ort .Body = "Veranstaltungsnummer: " & veranstaltungsnummer .BusyStatus = 2 .ReminderSet = False Dim pattern As Object Set pattern = .GetRecurrencePattern pattern.RecurrenceType = 0 ' daily pattern.Interval = 1 pattern.PatternStartDate = ws.Cells(eintraege(1), "B").Value pattern.PatternEndDate = ws.Cells(eintraege(eintraege.Count), "B").Value pattern.NoEndDate = False .Save End With For Each idx In eintraege ws.Cells(idx, "M").Value = "Serie: " & titel Next idx End If Weiter: Next i MsgBox "Einträge verarbeitet. Ergebnisse siehe Spalte M.", vbInformation End Sub Sub OutlookEintragErstellen(ByRef olItems As Object, datum As Date, startzeit As Date, endzeit As Date, titel As String, ort As String, nr As String) Dim item As Object, found As Boolean: found = False For Each item In olItems If item.Start = datum + TimeValue(startzeit) And item.Subject = titel Then found = True: Exit For End If Next item If Not found Then Dim appt As Object Set appt = olItems.Parent.Items.Add With appt .Start = datum + TimeValue(startzeit) .End = datum + TimeValue(endzeit) .Subject = titel .Location = ort .Body = "Veranstaltungsnummer: " & nr .ReminderSet = False .BusyStatus = 2 .Save End With End If End Sub Sub OutlookEintragLoeschen(ByRef olItems As Object, datum As Date, titel As String) Dim item As Object For Each item In olItems If Int(item.Start) = Int(datum) And item.Subject = titel Then item.Delete End If Next item End Sub