lerone / gist:a3ea2b07b8a243138d4902d56d3f1217

' 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 Dim filterDatum As String filterDatum = Format(Now, "mm/dd/yyyy hh:nn AMPM") Set gefilterteItems = olItems.Restrict("[Start] >= '" & filterDatum & "'") On Error Resume Next Set logSheet = ThisWorkbook.Sheets("Gelöschte Termine") If logSheet Is Nothing Then Set logSheet = ThisWorkbook.Sheets.Add logSheet.Name = "Gelöschte Termine" logSheet.Range("A1:D1").Value = Array("Datum", "Startzeit", "Titel", "Kalender") End If On Error GoTo 0 End If Set ws = ThisWorkbook.Sheets(1) lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row ReDim alreadyProcessed(1 To lastRow) For i = 2 To lastRow If alreadyProcessed(i) Then GoTo Weiter If ws.Cells(i, "B").Value < DateSerial(Year(Date), Month(Date), Day(Date)) Then ws.Cells(i, "M").Value = "übersprungen (Vergangenheit)" uebersprungenCount = uebersprungenCount + 1 GoTo Weiter End If 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)" uebersprungenCount = uebersprungenCount + 1 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 If Trim(titel) = "-" Or Trim(titel) = "- -" Or Trim(titel) = "" Then ws.Cells(i, "M").Value = "übersprungen (leerer Titel)" uebersprungenCount = uebersprungenCount + 1 GoTo Weiter End If ort = ws.Cells(i, "J").Value 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 Dim idx As Variant: idx = eintraege(1) startzeit = ws.Cells(idx, "C").Value endzeit = ws.Cells(idx, "D").Value datum = ws.Cells(idx, "B").Value If DRYRUN Then ws.Cells(idx, "M").Value = "[Simulation] Einzel: " & titel Else Call OutlookEintragErstellen(selectedCalendar, gefilteteItems, datum, startzeit, endzeit, titel, ort, veranstaltungsnummer) ws.Cells(idx, "M").Value = titel End If ws.Cells(idx, "N").Value = IIf(DRYRUN, "(Simulation)", selectedCalendar.Name) erstelltCount = erstelltCount + 1 With ws.Cells(idx, "M").Interior: .Color = RGB(198, 239, 206): End With Else For Each idx In eintraege datum = ws.Cells(idx, "B").Value If Not DRYRUN Then Call OutlookEintragLoeschen(gefilteteItems, datum, titel, logSheet, selectedCalendar.Name) geloeschtCount = geloeschtCount + 1 End If Next idx If DRYRUN Then For Each idx In eintraege ws.Cells(idx, "M").Value = "[Simulation] Serie: " & titel ws.Cells(idx, "N").Value = "(Simulation)" serienCount = serienCount + 1 With ws.Cells(idx, "M").Interior: .Color = RGB(255, 235, 156): End With Next idx Else 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 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 ws.Cells(idx, "N").Value = selectedCalendar.Name serienCount = serienCount + 1 With ws.Cells(idx, "M").Interior: .Color = RGB(255, 235, 156): End With Next idx End If End If Weiter: Next i MsgBox "Fertig in " & Format(Timer - startTime, "0.00") & " Sekunden." & vbCrLf & _ erstelltCount & " Einzeltermine erstellt" & vbCrLf & _ serienCount & " Serien-Einträge erstellt" & vbCrLf & _ geloeschtCount & " alte Termine gelöscht" & vbCrLf & _ uebersprungenCount & " Zeilen übersprungen", vbInformation End Sub ' Hilfsfunktion zum Erstellen eines Einzeltermins Sub OutlookEintragErstellen(ByVal selectedCalendar As Object, ByVal gefilteteItems As Object, ByVal datum As Date, ByVal startzeit As Date, ByVal endzeit As Date, ByVal titel As String, ByVal ort As String, ByVal veranstaltungsnummer As String) Dim item As Object, existingItem As Object Dim itemDate As Date Dim bodyText As String For Each existingItem In gefilteteItems If existingItem.Class = 26 Then ' nur AppointmentItems itemDate = Int(existingItem.Start) If itemDate = datum Then bodyText = "" & existingItem.Body If InStr(bodyText, veranstaltungsnummer) > 0 Then If existingItem.Subject <> titel Then Dim msg As VbMsgBoxResult msg = MsgBox("Ein Kalendereintrag mit derselben Veranstaltungsnummer existiert, aber der Titel unterscheidet sich:" & vbCrLf & _ "Bestehender Titel: " & existingItem.Subject & vbCrLf & _ "Neuer Titel: " & titel & vbCrLf & vbCrLf & _ "Trotzdem neuen Eintrag erstellen?", vbYesNo + vbExclamation, "Unstimmigkeit bei Titel") If msg = vbNo Then Exit Sub Else Exit Sub ' Duplikat mit gleichem Titel und Veranstaltungsnummer End If End If ' Duplikat erkannt Exit Sub End If End If Next Set item = selectedCalendar.Items.Add With item .Start = datum + startzeit .End = datum + endzeit .Subject = titel .Location = ort .Body = "Veranstaltungsnummer: " & veranstaltungsnummer .BusyStatus = 2 .ReminderSet = False .Save End With End Sub ' Hilfsfunktion zum Löschen vorhandener Einzeltermine mit gleichem Titel am gegebenen Datum Sub OutlookEintragLoeschen(ByVal gefilteteItems As Object, ByVal datum As Date, ByVal titel As String, ByVal logSheet As Worksheet, ByVal kalenderName As String) Dim item As Object Dim itemDate As Date For Each item In gefilteteItems If item.Class = 26 Then ' nur AppointmentItems itemDate = Int(item.Start) If itemDate = datum And item.Subject = titel Then logSheet.Cells(logSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(1, 4).Value = _ Array(Format(item.Start, "dd.mm.yyyy"), Format(item.Start, "hh:nn"), titel, kalenderName) item.Delete Exit For End If End If Next End Sub