lerone revised this gist . Go to revision
1 file changed, 170 insertions
gistfile1.txt(file created)
| @@ -0,0 +1,170 @@ | |||
| 1 | + | ' Serien-Kalendereinträge aus Excel erstellen mit Serienlogik, Löschung alter Einträge und Logging | |
| 2 | + | ||
| 3 | + | Sub SerienKalendereintraegeErstellen() | |
| 4 | + | Dim olApp As Object, olNS As Object | |
| 5 | + | Dim allCalendars As Collection, selectedCalendar As Object | |
| 6 | + | Dim calendarNames() As String, selectedIndex As Variant | |
| 7 | + | Dim olItems As Object, ws As Worksheet | |
| 8 | + | Dim lastRow As Long, i As Long, j As Long | |
| 9 | + | Dim eintraege As Collection | |
| 10 | + | Dim datum As Date, startzeit As Date, endzeit As Date | |
| 11 | + | Dim produkt As String, hinweis As String, veranstaltungsnummer As String | |
| 12 | + | Dim titel As String, ort As String | |
| 13 | + | Dim alreadyProcessed() As Boolean | |
| 14 | + | ||
| 15 | + | ' Outlook vorbereiten | |
| 16 | + | On Error Resume Next | |
| 17 | + | Set olApp = GetObject(, "Outlook.Application") | |
| 18 | + | If olApp Is Nothing Then Set olApp = CreateObject("Outlook.Application") | |
| 19 | + | On Error GoTo 0 | |
| 20 | + | If olApp Is Nothing Then | |
| 21 | + | MsgBox "Outlook konnte nicht gestartet werden.", vbCritical | |
| 22 | + | Exit Sub | |
| 23 | + | End If | |
| 24 | + | Set olNS = olApp.GetNamespace("MAPI") | |
| 25 | + | Set allCalendars = New Collection | |
| 26 | + | ||
| 27 | + | ' Kalender sammeln | |
| 28 | + | Dim store As Object, folder As Object | |
| 29 | + | For Each store In olNS.Folders | |
| 30 | + | For Each folder In store.Folders | |
| 31 | + | If folder.DefaultItemType = 1 Then allCalendars.Add folder | |
| 32 | + | Next folder | |
| 33 | + | Next store | |
| 34 | + | ||
| 35 | + | ' Kalenderauswahl | |
| 36 | + | ReDim calendarNames(1 To allCalendars.Count) | |
| 37 | + | For i = 1 To allCalendars.Count | |
| 38 | + | calendarNames(i) = allCalendars(i).Parent.Name & " – " & allCalendars(i).Name | |
| 39 | + | Next i | |
| 40 | + | selectedIndex = Application.InputBox("Wähle den Zielkalender aus (Zahl):" & vbCrLf & Join(calendarNames, vbCrLf), "Kalenderauswahl", Type:=1) | |
| 41 | + | If Not IsNumeric(selectedIndex) Or selectedIndex < 1 Or selectedIndex > allCalendars.Count Then Exit Sub | |
| 42 | + | ||
| 43 | + | Set selectedCalendar = allCalendars(selectedIndex) | |
| 44 | + | Set olItems = selectedCalendar.Items | |
| 45 | + | olItems.IncludeRecurrences = True | |
| 46 | + | olItems.Sort "[Start]" | |
| 47 | + | ||
| 48 | + | Set ws = ThisWorkbook.Sheets(1) | |
| 49 | + | lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row | |
| 50 | + | ReDim alreadyProcessed(1 To lastRow) | |
| 51 | + | ||
| 52 | + | ' Durch Einträge iterieren | |
| 53 | + | For i = 2 To lastRow | |
| 54 | + | If alreadyProcessed(i) Then GoTo Weiter | |
| 55 | + | ||
| 56 | + | ' Zeile validieren | |
| 57 | + | If Not IsDate(ws.Cells(i, "B").Value) Or ws.Cells(i, "G").Value = "" Then | |
| 58 | + | ws.Cells(i, "M").Value = "übersprungen (kein Datum/kein Produkt)" | |
| 59 | + | GoTo Weiter | |
| 60 | + | End If | |
| 61 | + | ||
| 62 | + | Set eintraege = New Collection | |
| 63 | + | veranstaltungsnummer = Trim(ws.Cells(i, "F").Value) | |
| 64 | + | produkt = Trim(ws.Cells(i, "G").Value) | |
| 65 | + | hinweis = Trim(ws.Cells(i, "L").Value) | |
| 66 | + | If InStr(hinweis, "Lehrgang: ") > 0 Then | |
| 67 | + | hinweis = Mid(hinweis, InStr(hinweis, "Lehrgang: ") + 10) | |
| 68 | + | End If | |
| 69 | + | titel = produkt & " - " & hinweis | |
| 70 | + | ort = ws.Cells(i, "J").Value | |
| 71 | + | ||
| 72 | + | ' Serie erkennen | |
| 73 | + | datum = ws.Cells(i, "B").Value | |
| 74 | + | eintraege.Add i | |
| 75 | + | alreadyProcessed(i) = True | |
| 76 | + | ||
| 77 | + | For j = i + 1 To lastRow | |
| 78 | + | If alreadyProcessed(j) Then GoTo SkipJ | |
| 79 | + | If Trim(ws.Cells(j, "F").Value) <> veranstaltungsnummer Then GoTo SkipJ | |
| 80 | + | If ws.Cells(j, "G").Value = "" Then GoTo SkipJ | |
| 81 | + | If Not IsDate(ws.Cells(j, "B").Value) Then GoTo SkipJ | |
| 82 | + | If ws.Cells(j, "B").Value - datum = 1 Or _ | |
| 83 | + | (Weekday(datum, vbMonday) = 5 And ws.Cells(j, "B").Value - datum = 3) Then | |
| 84 | + | eintraege.Add j | |
| 85 | + | alreadyProcessed(j) = True | |
| 86 | + | datum = ws.Cells(j, "B").Value | |
| 87 | + | Else | |
| 88 | + | Exit For | |
| 89 | + | End If | |
| 90 | + | SkipJ: | |
| 91 | + | Next j | |
| 92 | + | ||
| 93 | + | If eintraege.Count = 1 Then | |
| 94 | + | ' Einzeltermin | |
| 95 | + | Dim idx As Long: idx = eintraege(1) | |
| 96 | + | startzeit = ws.Cells(idx, "C").Value | |
| 97 | + | endzeit = ws.Cells(idx, "D").Value | |
| 98 | + | datum = ws.Cells(idx, "B").Value | |
| 99 | + | Call OutlookEintragErstellen(olItems, datum, startzeit, endzeit, titel, ort, veranstaltungsnummer) | |
| 100 | + | ws.Cells(idx, "M").Value = titel | |
| 101 | + | Else | |
| 102 | + | ' Alte Einzeltermine löschen | |
| 103 | + | For Each idx In eintraege | |
| 104 | + | datum = ws.Cells(idx, "B").Value | |
| 105 | + | Call OutlookEintragLoeschen(olItems, datum, titel) | |
| 106 | + | Next idx | |
| 107 | + | ||
| 108 | + | ' Serientermin | |
| 109 | + | Dim appt As Object | |
| 110 | + | Set appt = selectedCalendar.Items.Add | |
| 111 | + | With appt | |
| 112 | + | .Start = ws.Cells(eintraege(1), "B").Value + ws.Cells(eintraege(1), "C").Value | |
| 113 | + | .End = ws.Cells(eintraege(1), "B").Value + ws.Cells(eintraege(1), "D").Value | |
| 114 | + | .Subject = titel | |
| 115 | + | .Location = ort | |
| 116 | + | .Body = "Veranstaltungsnummer: " & veranstaltungsnummer | |
| 117 | + | .BusyStatus = 2 | |
| 118 | + | .ReminderSet = False | |
| 119 | + | ||
| 120 | + | Dim pattern As Object | |
| 121 | + | Set pattern = .GetRecurrencePattern | |
| 122 | + | pattern.RecurrenceType = 0 ' daily | |
| 123 | + | pattern.Interval = 1 | |
| 124 | + | pattern.PatternStartDate = ws.Cells(eintraege(1), "B").Value | |
| 125 | + | pattern.PatternEndDate = ws.Cells(eintraege(eintraege.Count), "B").Value | |
| 126 | + | pattern.NoEndDate = False | |
| 127 | + | ||
| 128 | + | .Save | |
| 129 | + | End With | |
| 130 | + | ||
| 131 | + | For Each idx In eintraege | |
| 132 | + | ws.Cells(idx, "M").Value = "Serie: " & titel | |
| 133 | + | Next idx | |
| 134 | + | End If | |
| 135 | + | Weiter: | |
| 136 | + | Next i | |
| 137 | + | MsgBox "Einträge verarbeitet. Ergebnisse siehe Spalte M.", vbInformation | |
| 138 | + | End Sub | |
| 139 | + | ||
| 140 | + | Sub OutlookEintragErstellen(ByRef olItems As Object, datum As Date, startzeit As Date, endzeit As Date, titel As String, ort As String, nr As String) | |
| 141 | + | Dim item As Object, found As Boolean: found = False | |
| 142 | + | For Each item In olItems | |
| 143 | + | If item.Start = datum + TimeValue(startzeit) And item.Subject = titel Then | |
| 144 | + | found = True: Exit For | |
| 145 | + | End If | |
| 146 | + | Next item | |
| 147 | + | If Not found Then | |
| 148 | + | Dim appt As Object | |
| 149 | + | Set appt = olItems.Parent.Items.Add | |
| 150 | + | With appt | |
| 151 | + | .Start = datum + TimeValue(startzeit) | |
| 152 | + | .End = datum + TimeValue(endzeit) | |
| 153 | + | .Subject = titel | |
| 154 | + | .Location = ort | |
| 155 | + | .Body = "Veranstaltungsnummer: " & nr | |
| 156 | + | .ReminderSet = False | |
| 157 | + | .BusyStatus = 2 | |
| 158 | + | .Save | |
| 159 | + | End With | |
| 160 | + | End If | |
| 161 | + | End Sub | |
| 162 | + | ||
| 163 | + | Sub OutlookEintragLoeschen(ByRef olItems As Object, datum As Date, titel As String) | |
| 164 | + | Dim item As Object | |
| 165 | + | For Each item In olItems | |
| 166 | + | If Int(item.Start) = Int(datum) And item.Subject = titel Then | |
| 167 | + | item.Delete | |
| 168 | + | End If | |
| 169 | + | Next item | |
| 170 | + | End Sub | |
Newer
Older