Sulprobil
Search…
sbTaskList
"Patience has its limits. Take it too far, and it is cowardice." [George Jackson]
If your team runs many different manual tasks, not all of them on each working day but only on specified weekdays or days of a month, then this tasklist creator might be of help to you.
In sheet Param define enter your team name or other reference which will be put into the footer of each page:
Define in sheet RawData which tasks needs to be done on which days and set the time of the day this needs to be started. It is not necessary to order all tasks by the time but it might help:
In sheet Today press button "Build Tasklist":
Print sheet Today. Let your team sign off the tasks (when they are done!) and let them note any exceptions (problems, errors, etc.) encountered. I use to scan the signed tasklist at the end of each day to stay paperless and to provide an audit trail. Let me know if you need an enhancement such as a Quarter Day column in sheet RawData: go to Contact page.
Please read my Disclaimer.
1
Enum rawdata_columns
2
rw_day = 1
3
rw_weekday
4
rw_time
5
rw_task
6
rw_completed_by
7
rw_approved_by
8
rw_exceptions
9
End Enum 'rawdata columns
10
11
Enum today_columns
12
td_time = 1
13
td_task
14
td_completed_by
15
td_approved_by
16
td_exceptions
17
End Enum 'today columns
18
19
Sub Build_Tasklist()
20
'https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/sbtasklist
21
'(C) (P) Bernd Plumhoff
22
'Change History:
23
'Version Date Programmer Change
24
'1.00 06/10/2010 Bernd Create
25
'1.01 17/01/2011 Bernd Recalculate before processing
26
'1.02 03/07/2018 Bernd Check for Excel version, don't use selects
27
'1.03 10/07/2018 Bernd xlPasteAllUsingSourceTheme to copy all different font sizes
28
'1.04 21/08/2018 Bernd Trashing Application.Printcommunication and setting all of
29
' [Left|Center|Right]Footer to avoid page errors
30
Dim lrw As Long, ltd As Long
31
Dim bTBD As Boolean 'To be done?
32
Dim v
33
34
'See https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/classes/systemstate to understand next two rows
35
Dim state As SystemState
36
Set state = New SystemState
37
38
Application.Calculate
39
40
wsToday.Rows("4:1048576").Delete
41
42
'Set destination column widths to source's
43
wsToday.Columns(Chr(64 + td_time) & ":" & Chr(64 + td_time)).ColumnWidth = _
44
wsRawData.Columns(Chr(64 + rw_time) & ":" & Chr(64 + rw_time)).ColumnWidth
45
wsToday.Columns(Chr(64 + td_task) & ":" & Chr(64 + td_task)).ColumnWidth = _
46
wsRawData.Columns(Chr(64 + rw_task) & ":" & Chr(64 + rw_task)).ColumnWidth
47
wsToday.Columns(Chr(64 + td_completed_by) & ":" & Chr(64 + td_completed_by)).ColumnWidth = _
48
wsRawData.Columns(Chr(64 + rw_completed_by) & ":" & Chr(64 + rw_completed_by)).ColumnWidth
49
wsToday.Columns(Chr(64 + td_approved_by) & ":" & Chr(64 + td_approved_by)).ColumnWidth = _
50
wsRawData.Columns(Chr(64 + rw_approved_by) & ":" & Chr(64 + rw_approved_by)).ColumnWidth
51
wsToday.Columns(Chr(64 + td_exceptions) & ":" & Chr(64 + td_exceptions)).ColumnWidth = _
52
wsRawData.Columns(Chr(64 + rw_exceptions) & ":" & Chr(64 + rw_exceptions)).ColumnWidth
53
54
lrw = 4: ltd = 4
55
Do While Not (IsEmpty(wsRawData.Cells(lrw, rw_time))) 'As long as we have tasks timed ...
56
57
Application.StatusBar = "Processing RawData row " & lrw & " ..."
58
'Determine whether source row needs to be copied
59
bTBD = False
60
If IsEmpty(wsRawData.Cells(lrw, rw_day)) And IsEmpty(wsRawData.Cells(lrw, rw_weekday)) Then
61
bTBD = True 'Empty rows will be copied
62
Else
63
'Check Month Day
64
If Not (IsEmpty(wsRawData.Cells(lrw, rw_day))) Then
65
For Each v In Split(wsRawData.Cells(lrw, rw_day).Text, ",")
66
If CLng(v) = wsParam.Range("Evaldate_WDMS") Or CLng(v) = wsParam.Range("Evaldate_WDME") Then
67
bTBD = True 'Right day from month start or month end: copy!
68
Exit For
69
End If
70
Next v
71
End If
72
'Check Weekday
73
If Not (IsEmpty(wsRawData.Cells(lrw, rw_weekday))) Then
74
For Each v In Split(wsRawData.Cells(lrw, rw_weekday).Text, ",")
75
If CLng(v) = wsParam.Range("Evaldate_Weekday") Then
76
bTBD = True 'Right weekday: copy!
77
Exit For
78
End If
79
Next v
80
End If
81
End If
82
83
If bTBD Then
84
'Task needs to be done - copy into sheet Today
85
wsRawData.Range(wsRawData.Cells(lrw, rw_time), wsRawData.Cells(lrw, rw_exceptions)).Copy
86
wsToday.Range(Cells(ltd, td_time), Cells(ltd, td_exceptions)).PasteSpecial Paste:=xlPasteValues
87
wsToday.Range(Cells(ltd, td_time), Cells(ltd, td_exceptions)).PasteSpecial Paste:=xlPasteFormats
88
wsToday.Range(Cells(ltd, td_time), Cells(ltd, td_exceptions)).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
89
wsToday.Rows(ltd & ":" & ltd).EntireRow.AutoFit
90
If wsToday.Rows(ltd & ":" & ltd).RowHeight < wsRawData.Rows(lrw & ":" & lrw).RowHeight Then
91
wsToday.Rows(ltd & ":" & ltd).RowHeight = wsRawData.Rows(lrw & ":" & lrw).RowHeight
92
End If
93
ltd = ltd + 1
94
End If
95
lrw = lrw + 1
96
Loop
97
98
With wsToday.PageSetup
99
.PrintTitleRows = "$1:$3"
100
.PrintArea = "$A$1:quot; & Chr(64 + td_exceptions) & "quot; & ltd - 1
101
.Orientation = xlPortrait
102
.FitToPagesWide = 1
103
.FitToPagesTall = 1 + Int(ltd / 5) 'Just to ensure that we have enough pages
104
.LeftFooter = wsParam.Range("Footer_Text")
105
.CenterFooter = ""
106
.RightFooter = "Page &P/&N"
107
End With
108
109
End Sub
Copied!
sbTasklist.xlsm
47KB
Binary
sbTasklist.xlsm
Last modified 1yr ago
Copy link