lerone / gist:4787ff4cb167477fa89b7f310bd91f30

' Serien-Kalendereinträge aus Excel erstellen mit Serienlogik, Löschung alter Einträge, Logging, Laufzeitmessung, Zusammenfassung und Simulationsmodus Sub SerienKalendereintraegeErstellen() ' Benutzer wird gefragt, ob Simulation gewünscht ist Dim userResponse As VbMsgBoxResult userResponse = MsgBox("Möchtest du eine Simulation durchführen (keine Einträge werden erstellt oder gelöscht)?", vbYesNo + vbQuestion, "Simulationsmodus") Dim DRYRUN As Boolean DRYRUN = (userResponse = vbYes) ' True = Simulation, False = Echtbetrieb 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, erstelltCount As Long, serienCount As Long, geloeschtCount As Long, uebersprungenCount 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 Dim startTime As Double Dim logSheet As Worksheet startTime = Timer If Not DRYRUN Then 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 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 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) MsgBox "Ausgewählter Kalender: " & selectedCalendar.Name, vbInformation, "Kalenderbestätigung" Set olItems = selectedCalendar.Items olItems.Sort "[Start]" olItems.IncludeRecurrences = True Dim gefilterteItems As Object Set gefilterteItems = olItems End If Set ws = ThisWorkbook.Sheets(1) lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row ReDim alreadyProcessed(1 To lastRow) Set eintraege = New Collection For i = 2 To lastRow If alreadyProcessed(i) Then GoTo Weiter If Not IsDate(ws.Cells(i, "B").Value) Then ws.Cells(i, "M").Value = "übersprungen (Datum fehlt)" uebersprungenCount = uebersprungenCount + 1 GoTo Weiter End If If ws.Cells(i, "C").Value = "" Then ws.Cells(i, "M").Value = "übersprungen (Startzeit fehlt)" uebersprungenCount = uebersprungenCount + 1 GoTo Weiter End If If ws.Cells(i, "G").Value = "" Then ws.Cells(i, "M").Value = "übersprungen (kein Produkt)" uebersprungenCount = uebersprungenCount + 1 GoTo Weiter End If datum = DateValue(ws.Cells(i, "B").Value) If IsDate(ws.Cells(i, "C").Value) Then startzeit = TimeValue(ws.Cells(i, "C").Value) Else ws.Cells(i, "M").Value = "übersprungen (ungültige Startzeit)" GoTo Weiter End If If IsDate(ws.Cells(i, "D").Value) Then endzeit = TimeValue(ws.Cells(i, "D").Value) Else ws.Cells(i, "M").Value = "übersprungen (ungültige Endzeit)" GoTo Weiter End If produkt = Trim(ws.Cells(i, "G").Value) veranstaltungsnummer = Trim(ws.Cells(i, "F").Value) hinweis = Trim(ws.Cells(i, "L").Value) ort = Trim(ws.Cells(i, "J").Value) If InStr(1, hinweis, "Lehrgang: ", vbTextCompare) > 0 Then hinweis = Mid(hinweis, InStr(1, hinweis, "Lehrgang: ", vbTextCompare) + 10) End If titel = produkt & " - " & hinweis If titel = " - " Or titel = "-" Then ws.Cells(i, "M").Value = "übersprungen (kein gültiger Titel)" GoTo Weiter End If ' Duplikatprüfung: Wenn in Outlook bereits ein Termin mit Datum und Veranstaltungsnummer vorhanden ist Dim skip As Boolean: skip = False If Not DRYRUN Then Dim existingItem As Object, itemDate As Date For Each existingItem In gefilterteItems If existingItem.Class = 26 Then itemDate = Int(existingItem.Start) If itemDate = datum Then If InStr(existingItem.Body, veranstaltungsnummer) > 0 Then If existingItem.Subject <> titel Then Dim msg As VbMsgBoxResult msg = MsgBox("Ein Eintrag mit gleicher Veranstaltungsnummer aber abweichendem Titel existiert: " & existingItem.Subject & vbCrLf & _ "Neuer Titel wäre: " & titel & vbCrLf & "Trotzdem ersetzen?", vbYesNo + vbExclamation) If msg = vbNo Then skip = True Else skip = True End If End If End If End If Next existingItem End If If skip Then ' Bestehenden Termin ggf. löschen If Not DRYRUN Then For Each existingItem In gefilterteItems If existingItem.Class = 26 And Int(existingItem.Start) = datum Then If InStr(existingItem.Body, veranstaltungsnummer) > 0 Then existingItem.Delete geloeschtCount = geloeschtCount + 1 Exit For End If End If Next End If ws.Cells(i, "M").Value = "ersetzt (gelöscht + neu)" GoTo Weiter End If ' Erstellung des Outlook-Termins oder Simulation If DRYRUN Then ws.Cells(i, "M").Value = "(Simulation) " & titel ws.Cells(i, "M").Interior.Color = RGB(200, 200, 200) Else Dim appt As Object Set appt = olApp.CreateItem(1) With appt .Start = datum + startzeit .End = datum + endzeit .Subject = titel .Location = ort .Body = veranstaltungsnummer .ReminderSet = False .BusyStatus = 2 .Save End With ws.Cells(i, "M").Value = titel erstelltCount = erstelltCount + 1 End If alreadyProcessed(i) = True ' Serientermin-Erkennung: gleiche Veranstaltungsnummer an aufeinanderfolgenden Werktagen Dim serieEndRow As Long: serieEndRow = i Do While serieEndRow + 1 <= lastRow And Not alreadyProcessed(serieEndRow + 1) Dim nextDatum As Date If Not IsDate(ws.Cells(serieEndRow + 1, "B").Value) Then Exit Do nextDatum = DateValue(ws.Cells(serieEndRow + 1, "B").Value) If ws.Cells(serieEndRow + 1, "F").Value <> veranstaltungsnummer Then Exit Do If Weekday(datum, vbMonday) = 5 Then ' Freitag If DateDiff("d", datum, nextDatum) <> 3 Then Exit Do ' Freitag → Montag Else If DateDiff("d", datum, nextDatum) <> 1 Then Exit Do End If If ws.Cells(serieEndRow + 1, "G").Value = "" Then Exit Do serieEndRow = serieEndRow + 1 Loop If serieEndRow > i Then ' Serien-Eintrag If Not DRYRUN Then Dim recurrenceAppt As Object Set recurrenceAppt = olApp.CreateItem(1) With recurrenceAppt .Start = datum + startzeit .End = datum + endzeit .Subject = titel .Location = ort .Body = veranstaltungsnummer .ReminderSet = False .BusyStatus = 2 .Save Dim pattern Set pattern = .GetRecurrencePattern pattern.RecurrenceType = 1 ' daily pattern.PatternStartDate = datum pattern.Occurrences = serieEndRow - i + 1 .Save End With For j = i To serieEndRow alreadyProcessed(j) = True ws.Cells(j, "M").Value = titel & " (Serie)" Next j serienCount = serienCount + 1 GoTo Weiter Else For j = i To serieEndRow alreadyProcessed(j) = True ws.Cells(j, "M").Value = "(Simulation) " & titel & " (Serie)" ws.Cells(j, "M").Interior.Color = RGB(180, 180, 180) Next j serienCount = serienCount + 1 GoTo Weiter End If End If Weiter: Next i Dim elapsedTime As Double elapsedTime = Timer - startTime MsgBox "Fertig. " & erstelltCount & " Termine erstellt, " & serienCount & " Serientermine erstellt, " & geloeschtCount & " ersetzt, " & uebersprungenCount & " übersprungen." & vbCrLf & _ "Laufzeit: " & Format(elapsedTime, "0.00") & " Sekunden", vbInformation End Sub