VBA Macro extracting individual services list from a district service plan in Excel

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>

Modul1.vba

' Findet alle Einträge zu einer bestimmten Person
' (c) Christoph Fischer, christoph.fischer@elkw.de
' 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