Skip to content

Instantly share code, notes, and snippets.

@potofcoffee

potofcoffee/Modul1.vba

Last active December 8, 2018 14:30
Show Gist options
  • Save potofcoffee/b85039f72e4bc6eb255c1ca3a2a6d491 to your computer and use it in GitHub Desktop.
Save potofcoffee/b85039f72e4bc6eb255c1ca3a2a6d491 to your computer and use it in GitHub Desktop.
Download ZIP
VBA Macro extracting individual services list from a district service plan in Excel
Raw
customUI.xml
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" >
<ribbon startFromScratch="false" >
<tabs>
<tab id="CustomTab" label="Dienstplan" >
<group id="SimpleControls" label="Dienstplan">
<button id="cfCustomButton1" label="Meine Gottesdienste" size="large" onAction="FindMyName" imageMso="HappyFace" />
</group>
</tab>
</tabs>
</ribbon>
</customUI>
Raw
Modul1.vba
' Findet alle Einträge zu einer bestimmten Person
' (c) Christoph Fischer, [email protected]
' v.1.10
'
' Aktuelle Version jeweils auf:
' https://gist.github.com/potofcoffee/b85039f72e4bc6eb255c1ca3a2a6d491
'
' CHANGELOG
'
' 2018-12-08 1.10 Gist angelegt und Verweis mit aufgenommen
' 2018-12-08 1.09 Seitenüberschrift in der Ausgabe
' 2018-12-08 1.08 Datumsbegrenzung für die Suche, Abbruchmöglichkeit
' 2018-12-08 1.07 Druckfreundliche Formatierung der Ergebnistabelle
' 2018-12-08 1.06 Suchergebnisse hellgrün hinterlegen
' 2018-12-08 1.05 Position während der Suche nicht verändern
' 2018-12-08 1.04 Mehrzeilige Ortsangaben
' 2018-12-08 1.03 6. Zeile für Tailfingen wird mit ausgegeben
' 2018-12-08 1.02 Anlass (Name des Festtags) wird mit ausgegeben
' 2018-12-08 1.01 Spezialfälle, Organisten und Mesner
' 2018-12-07 1.00 Erste funktionierende Version
Sub FindMyName(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
' Gesuchten Namen abfragen
' Standardwert: Nachname des aktuellen Benutzers
searchForName = ""
While searchForName = ""
searchForName = InputBox("Nachname, nach dem gesucht werden soll", "Einträge suchen", (Mid(Environ$("Username"), InStr(Environ$("Username"), ".") + 1)))
If StrPtr(searchForName) = 0 Then End
Wend
' 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 = "Plan für " & searchForName
' Überschriften für die Ausgabedatei
Title = "Gottesdienstliste für " & Chr(34) & searchForName & Chr(34)
If Not StartDate = "01.01.1970" Then Title = Title & " ab " & StartDate
If Not EndDate = "01.01.2100" Then Title = Title & " bis einschl. " & EndDate
outputSheet.Cells(1, 1).Value = Title
outputSheet.Cells(3, 1).Value = "Datum"
outputSheet.Cells(3, 2).Value = "Uhrzeit"
outputSheet.Cells(3, 3).Value = "Anlass"
outputSheet.Cells(3, 4).Value = "Ort"
outputSheet.Cells(3, 5).Value = "Pfarrer"
outputSheet.Cells(3, 6).Value = "Organist"
outputSheet.Cells(3, 7).Value = "Mesner"
outputSheet.Cells(3, 8).Value = "Besonderheit"
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 = 4
EventList = ""
LastYear = Year(Now())
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
' Suche
For x = 4 To 10
For y = 4 To 50
If InStr(ws.Cells(y, x).Value, searchForName) > 0 Then
'ws.Cells(y, x).Activate
' 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
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
' Referenzzeile ("abweichende Zeit") finden
specialTimeRow = 0
For Z = -3 To 0
If ws.Cells(y + Z, 3).Value = "abweichende Zeit" Then specialTimeRow = y + Z
Next Z
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
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
outputSheet.Cells(outputRow, 1) = EventDate
outputSheet.Cells(outputRow, 2) = EventTime
outputSheet.Cells(outputRow, 3) = ws.Cells(timeRow + 1, dateColumn).Value 'Anlass
outputSheet.Cells(outputRow, 4) = Location
outputSheet.Cells(outputRow, 5) = ws.Cells(specialTimeRow + 1, x)
outputSheet.Cells(outputRow, 6) = ws.Cells(specialTimeRow + 2, x)
outputSheet.Cells(outputRow, 7) = ws.Cells(specialTimeRow + 3, x)
outputSheet.Cells(outputRow, 8) = ws.Cells(specialTimeRow + 4, x)
' Nur für Tailfingen: auf Infos in der 6. Zeile (leere Beschriftung) prüfen
If (ws.Cells(specialTimeRow + 5, 2).Value = "") And Not (ws.Cells(specialTimeRow + 5, x).Value = "") Then
outputSheet.Cells(outputRow, 9) = ws.Cells(specialTimeRow + 5, x).Value
End If
' Suchbegriff hellgrün hinterlegen
outputRow = outputRow + 1
End If
End If
End If
Next y
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
' Überschriften formatieren
With outputSheet.Rows(1).Font
.Bold = True
.Size = 16
End With
With outputSheet.Rows(3)
.Interior.Color = RGB(0, 0, 0)
.Font.Color = RGB(255, 255, 255)
.Font.Bold = True
End With
' Streifen
For y = 4 To outputRow - 1
If (y Mod 2 = 1) Then outputSheet.Rows(y).Interior.Color = RGB(245, 245, 245)
Next y
' Suchergebnisse hellgrün hinterlegen
For y = 4 To outputRow - 1
For col = 4 To 9
If InStr(outputSheet.Cells(y, col).Value, searchForName) > 0 Then outputSheet.Cells(y, col).Interior.Color = RGB(240, 255, 240)
Next col
Next y
' Ausgabe anzeigen
outputSheet.Activate
End Sub
' Hilfsfunktion: Koordinaten der aktuellen Zelle anzeigen
Sub ShowCoordinates()
x = Application.ActiveCell.Column
y = Application.ActiveCell.Row
MsgBox y & " | " & x
End Sub
Sub ColumnWidth()
MsgBox Application.ActiveSheet.Columns(Application.ActiveCell.Column).ColumnWidth
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment