“Patience has its limits. Take it too far, and it is cowardice.” [George Jackson]

Abstract

Falls Ihr Team viele verschiedene manuelle Aufgaben erledigen muss, nicht alle täglich sondern auch an unterschiedlichen Wochentagen oder Arbeitstagen im Monat, dann könnte diese Aufgabenliste sie unterstützen.

Im Arbeitsblatt Param geben Sie Ihren Teamnamen oder eine andere Referenz ein, die im Fußbereich jeder Seite erscheinen soll, und auch den Arbeitstag:

sbTasklist_Param

Im Arbeitsblatt RawData definieren Sie welche Aufgaben täglich, wöchentlich, oder monatlich zu welchen Zeiten durchgeführt werden müssen. Sie müssen diese Aufgaben nicht nach der Uhrzeit sortieren, aber es könnte hilfreich sein:

sbTasklist_RawData

Nun drücken Sie den Button im Arbeitsblatt Param und Sie erhalten in Arbeitsblatt Today:

sbTasklist_Today

Drucken Sie das Arbeitsblatt Today aus. Lassen Sie Ihr Team alle Aufgaben abzeichnen (sobald sie erledigt wurden!) und lassen Sie sie alle aufgetretenen Ausnahmen (Probleme, Fehler, usw.) eintragen. Ich scannte normalerweise die signierte Taskliste am Ende jeden Tages, um einen papierlosen Revisionsnachweis zu haben.

Anmerkung: Sie können den gesamten Prozess papierlos durchführen, wenn Sie alle Eingaben elektronisch vornehmen lassen und die Ergebnisdatei als PDF abspeichern.

Appendix – Programmcode sbTaskList

Bitte beachten Sie, dass dieses Programm die Funktion ConvertTime benötigt, die Sie unter (externer Link!) https://stackoverflow.com/questions/3120915/get-timezone-information-in-vba-excel/20489651#20489651 finden können. (Keine Sorge, es ist in der u. g. Datei enthalten.)

Bitte den Haftungsausschluss im Impressum beachten.

Option Explicit

Enum rawdata_columns
    rw_day = 1
    rw_weekday
    rw_time
    rw_task
    rw_completed_by
    rw_approved_by
    rw_exceptions
    rw_day_increment '+1 means time is given for day after valuation day, for example
    rw_comment
End Enum 'rawdata columns

Enum today_columns
    td_time = 1
    td_task
    td_completed_by
    td_approved_by
    td_exceptions
End Enum 'today columns

Sub Build_Tasklist()
'Source (EN): http://www.sulprobil.com/sbtasklist_en/
'Source (DE): http://www.bplumhoff.de/sbtasklist_de/
'(C) (P) by Bernd Plumhoff 12-Sep-2022 PB V1.07

Dim bTBD               As Boolean 'To be done?

Dim dt                 As Date

Dim lrw                As Long
Dim ltd                As Long

Dim s                  As String

Dim v                  As Variant

'See http://www.sulprobil.com/systemstate_en/ to understand next two rows
Dim state              As SystemState

Set state = New SystemState

Application.Calculate
wsToday.Activate
wsToday.Rows("4:1048576").Delete

'Set destination column widths to source's
wsToday.Columns(Chr(64 + td_time) & ":" & Chr(64 + td_time)).ColumnWidth = _
    wsRawData.Columns(Chr(64 + rw_time) & ":" & Chr(64 + rw_time)).ColumnWidth
wsToday.Columns(Chr(64 + td_task) & ":" & Chr(64 + td_task)).ColumnWidth = _
    wsRawData.Columns(Chr(64 + rw_task) & ":" & Chr(64 + rw_task)).ColumnWidth
wsToday.Columns(Chr(64 + td_completed_by) & ":" & Chr(64 + td_completed_by)).ColumnWidth = _
    wsRawData.Columns(Chr(64 + rw_completed_by) & ":" & Chr(64 + rw_completed_by)).ColumnWidth
wsToday.Columns(Chr(64 + td_approved_by) & ":" & Chr(64 + td_approved_by)).ColumnWidth = _
    wsRawData.Columns(Chr(64 + rw_approved_by) & ":" & Chr(64 + rw_approved_by)).ColumnWidth
wsToday.Columns(Chr(64 + td_exceptions) & ":" & Chr(64 + td_exceptions)).ColumnWidth = _
    wsRawData.Columns(Chr(64 + rw_exceptions) & ":" & Chr(64 + rw_exceptions)).ColumnWidth
    
lrw = 4: ltd = 4
Do While Not (IsEmpty(wsRawData.Cells(lrw, rw_time))) 'As long as we have tasks timed ...

    Application.StatusBar = "Processing RawData row " & lrw & " ..."
    'Determine whether source row needs to be copied
    bTBD = False
    If IsEmpty(wsRawData.Cells(lrw, rw_day)) And IsEmpty(wsRawData.Cells(lrw, rw_weekday)) Then
        bTBD = True 'Empty rows will be copied
    Else
        'Check Month Day
        If Not (IsEmpty(wsRawData.Cells(lrw, rw_day))) Then
            For Each v In Split(wsRawData.Cells(lrw, rw_day).Text, ",")
                If CLng(v) = wsParam.Range("Evaldate_WDMS") Or CLng(v) = wsParam.Range("Evaldate_WDME") Then
                    bTBD = True 'Right day from month start or month end: copy!
                    Exit For
                End If
            Next v
        End If
        'Check Weekday
        If Not (IsEmpty(wsRawData.Cells(lrw, rw_weekday))) Then
            For Each v In Split(wsRawData.Cells(lrw, rw_weekday).Text, ",")
                If CLng(v) = wsParam.Range("Evaldate_Weekday") Then
                    bTBD = True 'Right weekday: copy!
                    Exit For
                End If
            Next v
        End If
    End If
            
    If bTBD Then
        'Task needs to be done - copy into sheet Today
        wsRawData.Range(wsRawData.Cells(lrw, rw_time), wsRawData.Cells(lrw, rw_exceptions)).Copy
        wsToday.Range(Cells(ltd, td_time), Cells(ltd, td_exceptions)).PasteSpecial Paste:=xlPasteValues
        wsToday.Range(Cells(ltd, td_time), Cells(ltd, td_exceptions)).PasteSpecial Paste:=xlPasteFormats
        wsToday.Range(Cells(ltd, td_time), Cells(ltd, td_exceptions)).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
        
        dt = Range("Evaldate") + wsRawData.Cells(lrw, rw_day_increment) + wsRawData.Cells(lrw, rw_time)
        dt = ConvertTime(dt, "Central European Standard Time", "Pacific Standard Time")
        s = Format(dt, "hh:nn") & " PST" & IIf(dt - Range("Evaldate") > 1, _
            " +" & Format(Int(dt - Range("Evaldate")), "0"), "") & vbCrLf
        dt = Range("Evaldate") + wsRawData.Cells(lrw, rw_day_increment) + wsRawData.Cells(lrw, rw_time)
        s = s & Format(dt, "hh:nn") & " CET" & IIf(dt - Range("Evaldate") > 1, _
            " +" & Format(Int(dt - Range("Evaldate")), "0"), "") & vbCrLf
        dt = ConvertTime(dt, "Central European Standard Time", "India Standard Time")
        s = s & Format(dt, "hh:nn") & " IST" & IIf(dt - Range("Evaldate") > 1, _
            " +" & Format(Int(dt - Range("Evaldate")), "0"), "") & vbCrLf
        wsToday.Cells(ltd, td_time) = s
        
        wsToday.Rows(ltd & ":" & ltd).EntireRow.AutoFit
        If wsToday.Rows(ltd & ":" & ltd).RowHeight < wsRawData.Rows(lrw & ":" & lrw).RowHeight Then
            wsToday.Rows(ltd & ":" & ltd).RowHeight = wsRawData.Rows(lrw & ":" & lrw).RowHeight
        End If
        ltd = ltd + 1
    End If
    lrw = lrw + 1
Loop

With wsToday.PageSetup
    .PrintTitleRows = "$1:$3"
    .PrintArea = "$A$1:$" & Chr(64 + td_exceptions) & "$" & ltd - 1
    On Error Resume Next 'Quick and dirty because next command rows will fail in case no printer is defined
    .Orientation = xlPortrait
    .FitToPagesWide = 1
    .FitToPagesTall = 1 + Int(ltd / 5) 'Just to ensure that we have enough pages
    .LeftFooter = wsParam.Range("Footer_Text")
    .CenterFooter = ""
    .RightFooter = "Page &P/&N"
    On Error GoTo 0
End With

End Sub

Download

Bitte den Haftungsausschluss im Impressum beachten.

sbtasklist.xlsm [66 KB Excel Datei, ohne jegliche Gewährleistung]