Created
January 31, 2019 08:42
-
-
Save potofcoffee/e05a749c31c093ab422383bcd52fff49 to your computer and use it in GitHub Desktop.
VBA Macro exporting services from a district service plan
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| ' Findet alle Einträge zu einer bestimmten Person | |
| ' (c) Christoph Fischer, [email protected] | |
| ' v.1.00 | |
| ' | |
| ' Aktuelle Version jeweils auf: | |
| ' | |
| ' CHANGELOG | |
| ' | |
| ' 2019-01-31 1.00 Erste funktionierende Version | |
| Sub ExportForBulletin(control As IRibbonControl) | |
| Dim sourceWb As Workbook | |
| Dim outputWb As Workbook | |
| Dim outputSheet As Worksheet | |
| Dim returnToCell As Range | |
| Dim ws As Worksheet | |
| Dim FindRow As Range | |
| Dim timeRow As Integer | |
| ' Startdatum | |
| StartDate = "" | |
| While Not IsDate(StartDate) | |
| StartDate = Format(Now(), "dd.mm.yyyy") | |
| StartDate = InputBox("Datum, ab dem gesucht werden soll (leer lassen, um alle Einträge zu suchen)", "Einträge suchen", StartDate) | |
| If StrPtr(StartDate) = 0 Then End | |
| If StartDate = "" Then StartDate = "01.01.1970" | |
| Wend | |
| ' Startdatum | |
| EndDate = "" | |
| While Not IsDate(EndDate) | |
| EndDate = InputBox("Datum, bis zu dem gesucht werden soll (leer lassen, um alle Einträge zu suchen)", "Einträge suchen", EndDate) | |
| If StrPtr(EndDate) = 0 Then End | |
| If EndDate = "" Then EndDate = "01.01.2100" | |
| Wend | |
| ' Ausgabedatei erzeugen | |
| Set sourceWb = ActiveWorkbook | |
| Set outputWb = Workbooks.Add | |
| Set outputSheet = outputWb.Worksheets.Add | |
| outputSheet.Name = "Gemeindebrief" | |
| outputSheet.Columns(3).ColumnWidth = outputSheet.Columns(3).ColumnWidth * 3 | |
| For col = 4 To 7 | |
| outputSheet.Columns(col).ColumnWidth = outputSheet.Columns(col).ColumnWidth * 2 | |
| Next col | |
| outputRow = 1 | |
| Dim times As New Collection | |
| Dim timeRows As New Collection | |
| EventList = "" | |
| LastYear = Year(Now()) | |
| LastEventDate = 0 | |
| For Each ws In sourceWb.Worksheets | |
| sheetName = Trim(ws.Name) | |
| While (Not IsNumeric(Right(sheetName, 1))) | |
| sheetName = Trim(Left(sheetName, Len(sheetName) - 1)) | |
| Wend | |
| SheetYear = Right(ws.Name, 4) | |
| If Not IsNumeric(SheetYear) Then SheetYear = LastYear | |
| If CInt(SheetYear < 100) Then SheetYear = "2" & SheetYear | |
| LastYear = SheetYear | |
| 'ws.Activate | |
| ' Zeile mit Zeitangabe finden (eine der ersten 3 Zeilen) | |
| timeRow = 2 | |
| For y = 1 To 3 | |
| If ws.Cells(y, 2).Value = "Uhrzeit" Then timeRow = y | |
| Next y | |
| ' Jede Spalte durchgehen | |
| For x = 4 To 10 | |
| ' Prüfen, ob sich in dieser Spalte etwas befindet | |
| ' Datum | |
| dateColumn = x | |
| If (ws.Cells(timeRow, x).Value = "" Or ws.Cells(timeRow, x).Value = 0) Then | |
| dateColumn = x - 1 'special case: two columns for one day | |
| End If | |
| If (ws.Cells(timeRow, x).Value <> "") Then | |
| ' Uhrzeitlisten leeren | |
| For i = 1 To times.Count | |
| times.Remove (1) | |
| timeRows.Remove (1) | |
| Next i | |
| ' Erste Schleife: Uhrzeiten erfassen und sortieren | |
| For y = 4 To 22 Step 6 | |
| EventDate = Trim(ws.Cells(timeRow, dateColumn).Value) | |
| If Not (Right(EventDate, 1)) = "." Then EventDate = EventDate & "." | |
| EventDate = EventDate & Trim(SheetYear) | |
| ' Prüfen, ob Datum überhaupt gelistet werden soll | |
| If (CDate(EventDate) >= CDate(StartDate)) And (CDate(EventDate) <= CDate(EndDate)) Then | |
| 'Prüfen, ob ein Pfarrer eingetragen ist | |
| If (ws.Cells(y + 1, x).Value <> "") Then | |
| 'Uhrzeit finden | |
| If (ws.Cells(y, x).Value <> "") Then eventTime = ws.Cells(y, x).Value Else eventTime = ws.Cells(y, 2) | |
| eventTime = Trim(Replace(eventTime, "Uhr", "")) | |
| If IsNumeric(eventTime) Then | |
| If (CLng(eventTime) < 2) Then | |
| eventTime = Format(eventTime, "hh:nn") | |
| End If | |
| End If | |
| ' sanitize time | |
| eventTimeTmp = "" | |
| For i = 1 To Len(eventTime) | |
| If (IsNumeric(Mid(eventTime, i, 1))) Then eventTimeTmp = eventTimeTmp & Mid(eventTime, i, 1) | |
| Next i | |
| eventTimeInt = CInt(Replace(eventTimeTmp, ":", "")) | |
| If (times.Count = 0) Then | |
| times.Add eventTimeInt | |
| timeRows.Add y | |
| Else | |
| done = False | |
| For i = 1 To times.Count | |
| If Not done Then | |
| If eventTimeInt < times(i) Then | |
| done = True | |
| times.Add Item:=eventTimeInt, before:=i | |
| timeRows.Add Item:=y, before:=i | |
| ElseIf eventTimeInt = times(i) Then | |
| ' gleiche Uhrzeit = doppelter Eintrag? | |
| ' prüfen anhand des Pfarrereintrags (der selbe Pfarrer kann nicht bei 2 Veranstaltungen sein) | |
| If (ws.Cells(timeRows(i) + 1, x).Value = ws.Cells(y + 1, x).Value) Then done = True | |
| End If | |
| End If | |
| Next i | |
| If (Not done) Then | |
| times.Add eventTimeInt | |
| timeRows.Add y | |
| End If | |
| End If | |
| End If | |
| End If | |
| Next y | |
| For i = 1 To times.Count | |
| y = timeRows(i) | |
| 'ws.Cells(y, x).Activate | |
| EventDate = Trim(ws.Cells(timeRow, dateColumn).Value) | |
| If Not (Right(EventDate, 1)) = "." Then EventDate = EventDate & "." | |
| EventDate = EventDate & Trim(SheetYear) | |
| ' Prüfen, ob Datum überhaupt gelistet werden soll | |
| If (CDate(EventDate) >= CDate(StartDate)) And (CDate(EventDate) <= CDate(EndDate)) Then | |
| specialTimeRow = y | |
| 'Prüfen, ob ein Pfarrer eingetragen ist | |
| If (ws.Cells(specialTimeRow + 1, x).Value <> "") Then | |
| If (specialTimeRow > 0) Then | |
| ' Reguläre Zeitangabe | |
| eventTime = "" | |
| For Z = specialTimeRow To specialTimeRow + 4 | |
| If eventTime = "" Then | |
| eventTime = Trim(ws.Cells(Z, 2).Value) | |
| End If | |
| Next Z | |
| ' Abweichende Zeitangabe? | |
| If Not ws.Cells(specialTimeRow, x).Value = "" Then eventTime = ws.Cells(specialTimeRow, x).Value | |
| ' Zeitangabe formatieren | |
| eventTime = Trim(Replace(eventTime, "Uhr", "")) | |
| If IsNumeric(eventTime) Then | |
| If (CLng(eventTime) < 2) Then | |
| eventTime = Format(eventTime, "hh.nn") | |
| End If | |
| Else | |
| eventTime = Replace(eventTime, ":", ".") | |
| End If | |
| eventTime = Trim(eventTime) & " Uhr" | |
| ' Ortsangaben | |
| Location = "" | |
| For Z = specialTimeRow To specialTimeRow + 4 | |
| If Not (ws.Cells(Z, 1).Value = "") Then | |
| If Not Location = "" Then Location = Location & ", " | |
| Location = Location & Trim(ws.Cells(Z, 1).Value) | |
| End If | |
| Next Z | |
| ' Ausgabe | |
| EventSubject = ws.Cells(specialTimeRow + 4, x).Value | |
| EventTitle = ws.Cells(specialTimeRow + 1, x).Value | |
| If (EventSubject <> "") Then | |
| EventTitle = EventTitle & " - " & Trim(EventSubject) | |
| If (ws.Cells(specialTimeRow + 5, x).Value <> "") Then EventTitle = EventTitle & ", " & Trim(ws.Cells(specialTimeRow + 5, x).Value) | |
| End If | |
| EventTitle = Replace(Replace(EventTitle, " | ", "/"), "/ ", "/") | |
| If (LastEventDate <> EventDate) Then | |
| If (outputRow > 1) Then outputRow = outputRow + 1 'Leerzeile, wenn Datum wechselt | |
| outputSheet.Cells(outputRow, 1) = EventDate | |
| occasionMarker = False | |
| Else | |
| If (Not occasionMarker) Then outputSheet.Cells(outputRow, 1) = ws.Cells(timeRow + 1, dateColumn).Value | |
| occasionMarker = True | |
| End If | |
| outputSheet.Cells(outputRow, 2) = eventTime | |
| outputSheet.Cells(outputRow, 3) = Location | |
| outputSheet.Cells(outputRow, 4) = EventTitle | |
| LastEventDate = EventDate | |
| outputRow = outputRow + 1 | |
| End If | |
| End If | |
| End If | |
| Next i | |
| End If | |
| Next x | |
| Next ws | |
| ' Ausgabedatei weiter formatieren | |
| With outputSheet | |
| With .PageSetup | |
| .Orientation = xlLandscape | |
| .LeftMargin = Application.CentimetersToPoints(0.64) | |
| .RightMargin = Application.CentimetersToPoints(0.64) | |
| End With | |
| With .Cells | |
| .Font.Name = "Arial" | |
| .Font.Size = 10 | |
| End With | |
| .Range("A2:I1000").Columns.AutoFit | |
| .Columns(4).ColumnWidth = 13.29 | |
| End With | |
| ' Ausgabe anzeigen | |
| outputSheet.Activate | |
| End Sub | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment