' 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

    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 filterStart As String
    filterStart = "[Start] >= '" & Format(Date, "ddddd h:nn AMPM") & "'"
    Set gefilterteItems = olItems.Restrict(filterStart)

    Debug.Print "Kalender geladen: " & selectedCalendar.Name & ", " & gefilterteItems.Count & " gefilterte Einträge"
    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
        Debug.Print "---"
        Debug.Print "Verarbeite Zeile: " & i
        Debug.Print "Datum: " & ws.Cells(i, "B").Text
        Debug.Print "Startzeit: " & ws.Cells(i, "C").Text
        Debug.Print "Endzeit: " & ws.Cells(i, "D").Text
        Debug.Print "Produkt: " & ws.Cells(i, "G").Text
        Debug.Print "Hinweis für Trainer: " & ws.Cells(i, "L").Text
        Debug.Print "Veranstaltungsnummer: " & ws.Cells(i, "F").Text
        Debug.Print "Ort: " & ws.Cells(i, "J").Text
        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