Like 0
Fork 0

Last active 1753356033

lerone revised this gist 1753354455. Go to revision

1 file changed, 241 insertions

gistfile1.txt(file created)

@@ -0,0 +1,241 @@
1 + ' Serien-Kalendereinträge aus Excel erstellen mit Serienlogik, Löschung alter Einträge, Logging, Laufzeitmessung, Zusammenfassung und Simulationsmodus
2 +
3 + Sub SerienKalendereintraegeErstellen()
4 + ' Benutzer wird gefragt, ob Simulation gewünscht ist
5 + Dim userResponse As VbMsgBoxResult
6 + userResponse = MsgBox("Möchtest du eine Simulation durchführen (keine Einträge werden erstellt oder gelöscht)?", vbYesNo + vbQuestion, "Simulationsmodus")
7 + Dim DRYRUN As Boolean
8 + DRYRUN = (userResponse = vbYes) ' True = Simulation, False = Echtbetrieb
9 +
10 + Dim olApp As Object, olNS As Object
11 + Dim allCalendars As Collection, selectedCalendar As Object
12 + Dim calendarNames() As String, selectedIndex As Variant
13 + Dim olItems As Object, ws As Worksheet
14 + Dim lastRow As Long, i As Long, j As Long, erstelltCount As Long, serienCount As Long, geloeschtCount As Long, uebersprungenCount As Long
15 + Dim eintraege As Collection
16 + Dim datum As Date, startzeit As Date, endzeit As Date
17 + Dim produkt As String, hinweis As String, veranstaltungsnummer As String
18 + Dim titel As String, ort As String
19 + Dim alreadyProcessed() As Boolean
20 + Dim startTime As Double
21 + Dim logSheet As Worksheet
22 +
23 + startTime = Timer
24 +
25 + If Not DRYRUN Then
26 + On Error Resume Next
27 + Set olApp = GetObject(, "Outlook.Application")
28 + If olApp Is Nothing Then Set olApp = CreateObject("Outlook.Application")
29 + On Error GoTo 0
30 + If olApp Is Nothing Then
31 + MsgBox "Outlook konnte nicht gestartet werden.", vbCritical
32 + Exit Sub
33 + End If
34 + Set olNS = olApp.GetNamespace("MAPI")
35 + Set allCalendars = New Collection
36 +
37 + Dim store As Object, folder As Object
38 + For Each store In olNS.Folders
39 + For Each folder In store.Folders
40 + If folder.DefaultItemType = 1 Then allCalendars.Add folder
41 + Next folder
42 + Next store
43 +
44 + ReDim calendarNames(1 To allCalendars.Count)
45 + For i = 1 To allCalendars.Count
46 + calendarNames(i) = allCalendars(i).Parent.Name & " – " & allCalendars(i).Name
47 + Next i
48 + selectedIndex = Application.InputBox("Wähle den Zielkalender aus (Zahl):" & vbCrLf & Join(calendarNames, vbCrLf), "Kalenderauswahl", Type:=1)
49 + If Not IsNumeric(selectedIndex) Or selectedIndex < 1 Or selectedIndex > allCalendars.Count Then Exit Sub
50 +
51 + Set selectedCalendar = allCalendars(selectedIndex)
52 + Set olItems = selectedCalendar.Items
53 + olItems.IncludeRecurrences = True
54 + olItems.Sort "[Start]"
55 +
56 + On Error Resume Next
57 + Set logSheet = ThisWorkbook.Sheets("Gelöschte Termine")
58 + If logSheet Is Nothing Then
59 + Set logSheet = ThisWorkbook.Sheets.Add
60 + logSheet.Name = "Gelöschte Termine"
61 + logSheet.Range("A1:D1").Value = Array("Datum", "Startzeit", "Titel", "Kalender")
62 + End If
63 + On Error GoTo 0
64 + End If
65 +
66 + Set ws = ThisWorkbook.Sheets(1)
67 + lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
68 + ReDim alreadyProcessed(1 To lastRow)
69 +
70 + For i = 2 To lastRow
71 + If alreadyProcessed(i) Then GoTo Weiter
72 +
73 + If ws.Cells(i, "B").Value < Date Then
74 + ws.Cells(i, "M").Value = "übersprungen (Vergangenheit)"
75 + uebersprungenCount = uebersprungenCount + 1
76 + GoTo Weiter
77 + End If
78 +
79 + If Not IsDate(ws.Cells(i, "B").Value) Or ws.Cells(i, "G").Value = "" Then
80 + ws.Cells(i, "M").Value = "übersprungen (kein Datum/kein Produkt)"
81 + uebersprungenCount = uebersprungenCount + 1
82 + GoTo Weiter
83 + End If
84 +
85 + Set eintraege = New Collection
86 + veranstaltungsnummer = Trim(ws.Cells(i, "F").Value)
87 + produkt = Trim(ws.Cells(i, "G").Value)
88 + hinweis = Trim(ws.Cells(i, "L").Value)
89 + If InStr(hinweis, "Lehrgang: ") > 0 Then
90 + hinweis = Mid(hinweis, InStr(hinweis, "Lehrgang: ") + 10)
91 + End If
92 + titel = produkt & " - " & hinweis
93 + ort = ws.Cells(i, "J").Value
94 +
95 + datum = ws.Cells(i, "B").Value
96 + eintraege.Add i
97 + alreadyProcessed(i) = True
98 +
99 + For j = i + 1 To lastRow
100 + If alreadyProcessed(j) Then GoTo SkipJ
101 + If Trim(ws.Cells(j, "F").Value) <> veranstaltungsnummer Then GoTo SkipJ
102 + If ws.Cells(j, "G").Value = "" Then GoTo SkipJ
103 + If Not IsDate(ws.Cells(j, "B").Value) Then GoTo SkipJ
104 + If ws.Cells(j, "B").Value - datum = 1 Or _
105 + (Weekday(datum, vbMonday) = 5 And ws.Cells(j, "B").Value - datum = 3) Then
106 + eintraege.Add j
107 + alreadyProcessed(j) = True
108 + datum = ws.Cells(j, "B").Value
109 + Else
110 + Exit For
111 + End If
112 + SkipJ:
113 + Next j
114 +
115 + If eintraege.Count = 1 Then
116 + Dim idx As Variant: idx = eintraege(1)
117 + startzeit = ws.Cells(idx, "C").Value
118 + endzeit = ws.Cells(idx, "D").Value
119 + datum = ws.Cells(idx, "B").Value
120 + If DRYRUN Then
121 + ws.Cells(idx, "M").Value = "[Simulation] Einzel: " & titel
122 + Else
123 + Call OutlookEintragErstellen(olItems, datum, startzeit, endzeit, titel, ort, veranstaltungsnummer)
124 + ws.Cells(idx, "M").Value = titel
125 + End If
126 + ws.Cells(idx, "N").Value = IIf(DRYRUN, "(Simulation)", selectedCalendar.Name)
127 + erstelltCount = erstelltCount + 1
128 + With ws.Cells(idx, "M").Interior: .Color = RGB(198, 239, 206): End With
129 + Else
130 + For Each idx In eintraege
131 + datum = ws.Cells(idx, "B").Value
132 + If Not DRYRUN Then
133 + Call OutlookEintragLoeschen(olItems, datum, titel, logSheet, selectedCalendar.Name)
134 + geloeschtCount = geloeschtCount + 1
135 + End If
136 + Next idx
137 + If DRYRUN Then
138 + For Each idx In eintraege
139 + ws.Cells(idx, "M").Value = "[Simulation] Serie: " & titel
140 + ws.Cells(idx, "N").Value = "(Simulation)"
141 + serienCount = serienCount + 1
142 + With ws.Cells(idx, "M").Interior: .Color = RGB(255, 235, 156): End With
143 + Next idx
144 + Else
145 + Dim appt As Object
146 + Set appt = selectedCalendar.Items.Add
147 + With appt
148 + .Start = ws.Cells(eintraege(1), "B").Value + ws.Cells(eintraege(1), "C").Value
149 + .End = ws.Cells(eintraege(1), "B").Value + ws.Cells(eintraege(1), "D").Value
150 + .Subject = titel
151 + .Location = ort
152 + .Body = "Veranstaltungsnummer: " & veranstaltungsnummer
153 + .BusyStatus = 2
154 + .ReminderSet = False
155 + Dim pattern As Object
156 + Set pattern = .GetRecurrencePattern
157 + pattern.RecurrenceType = 0
158 + pattern.Interval = 1
159 + pattern.PatternStartDate = ws.Cells(eintraege(1), "B").Value
160 + pattern.PatternEndDate = ws.Cells(eintraege(eintraege.Count), "B").Value
161 + pattern.NoEndDate = False
162 + .Save
163 + End With
164 + For Each idx In eintraege
165 + ws.Cells(idx, "M").Value = "Serie: " & titel
166 + ws.Cells(idx, "N").Value = selectedCalendar.Name
167 + serienCount = serienCount + 1
168 + With ws.Cells(idx, "M").Interior: .Color = RGB(255, 235, 156): End With
169 + Next idx
170 + End If
171 + End If
172 + Weiter:
173 + Next i
174 +
175 + MsgBox "Fertig in " & Format(Timer - startTime, "0.00") & " Sekunden." & vbCrLf & _
176 + erstelltCount & " Einzeltermine erstellt" & vbCrLf & _
177 + serienCount & " Serien-Einträge erstellt" & vbCrLf & _
178 + geloeschtCount & " alte Termine gelöscht" & vbCrLf & _
179 + uebersprungenCount & " Zeilen übersprungen", vbInformation
180 + End Sub
181 +
182 +
183 + ' Hilfsfunktion zum Erstellen eines Einzeltermins
184 + Sub OutlookEintragErstellen(ByVal olItems 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)
185 + Dim item As Object, existingItem As Object
186 + Dim itemDate As Date
187 + Dim bodyText As String
188 +
189 + For Each existingItem In olItems
190 + If existingItem.Class = 26 Then ' nur AppointmentItems
191 + itemDate = Int(existingItem.Start)
192 + If itemDate = datum Then
193 + bodyText = "" & existingItem.Body
194 + If InStr(bodyText, veranstaltungsnummer) > 0 Then
195 + If existingItem.Subject <> titel Then
196 + Dim msg As VbMsgBoxResult
197 + msg = MsgBox("Ein Kalendereintrag mit derselben Veranstaltungsnummer existiert, aber der Titel unterscheidet sich:" & vbCrLf & _
198 + "Bestehender Titel: " & existingItem.Subject & vbCrLf & _
199 + "Neuer Titel: " & titel & vbCrLf & vbCrLf & _
200 + "Trotzdem neuen Eintrag erstellen?", vbYesNo + vbExclamation, "Unstimmigkeit bei Titel")
201 + If msg = vbNo Then Exit Sub
202 + Else
203 + Exit Sub ' Duplikat mit gleichem Titel und Veranstaltungsnummer
204 + End If
205 + End If
206 + ' Duplikat erkannt
207 + Exit Sub
208 + End If
209 + End If
210 + Next
211 +
212 + Set item = olItems.Add
213 + With item
214 + .Start = datum + startzeit
215 + .End = datum + endzeit
216 + .Subject = titel
217 + .Location = ort
218 + .Body = "Veranstaltungsnummer: " & veranstaltungsnummer
219 + .BusyStatus = 2
220 + .ReminderSet = False
221 + .Save
222 + End With
223 + End Sub
224 +
225 +
226 + ' Hilfsfunktion zum Löschen vorhandener Einzeltermine mit gleichem Titel am gegebenen Datum
227 + Sub OutlookEintragLoeschen(ByVal olItems As Object, ByVal datum As Date, ByVal titel As String, ByVal logSheet As Worksheet, ByVal kalenderName As String)
228 + Dim item As Object
229 + Dim itemDate As Date
230 + For Each item In olItems
231 + If item.Class = 26 Then ' nur AppointmentItems
232 + itemDate = Int(item.Start)
233 + If itemDate = datum And item.Subject = titel Then
234 + logSheet.Cells(logSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(1, 4).Value = _
235 + Array(Format(item.Start, "dd.mm.yyyy"), Format(item.Start, "hh:nn"), titel, kalenderName)
236 + item.Delete
237 + Exit For
238 + End If
239 + End If
240 + Next
241 + End Sub
Newer Older

Powered by Opengist ⋅ Load: 9ms⋅

English