Not many people on projects typically have MS Project licenses and can read my project plan on their own. Nonetheless everyone has to know what’s going on. Here is a simple macro to export a list of tasks to an Excel spreadsheet for all active resources on the project. You can
- exclude resources (see the NoShow list)
- customize the target directory (defaultl “C\:temp”)
- customize the file names (defaults to Timesheet – <Year> – <Calendar Week> – <Name>
Here is what the resulting files look like. Note that work, actual work and remaining work are displayed in days. The first column contains a field (text28) which I use in MS Project to assign tasks to projects.
All tasks that finish in the current week are highlighted in red, all task that finish in the subsequent week are highlighted in yellow.
If you run the macro twice in one week, you’ll first have to remove the files of the first run.
Caveat: the macro works reliably only if there is at most one resource assigned to a task.
No idea, how to use this code? Check out, how to add VBA code to your computer.
Option Explicit
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
'
' dumps all tasks for all resources into individual excel files
' works only iff there is at most one resource per task
'
Public Sub swaCreateTimeSheets()
Dim r As Resource
Dim t As Task
Dim realname As String
Dim swaPath As String
Dim swaPrefix As String
Dim swaFilename As String
Dim swaRange As String
Dim i As Integer
Dim datTestDate As Date
Dim intCalendarWeek As Integer
Dim intCalendarWeekFinish As Integer
Dim strCalendarWeek As String
Dim excelApp As Object, swaWorkbook As Object
Dim swaWorksheet As Worksheet
' list path to files here
swaPath = "C:\TEMP\" ' must finish with backslash and MUST BE ACCESSIBLE FOR USER (hint C:\ does not work in my case)
' prefix for filename
swaPrefix = "Timesheet"
' list here all employees that should not be dumped
Dim NoShow(17) As String
NoShow(0) = "Mickey Mouse"
NoShow(1) = "Donald Duck"
NoShow(2) = "Joe Schmoe"
NoShow(3) = "NN"
NoShow(4) = "NN"
NoShow(5) = "NN"
NoShow(6) = "NN"
NoShow(7) = "NN"
NoShow(8) = "NN"
NoShow(9) = "NN"
NoShow(10) = "NN"
NoShow(11) = "NN"
NoShow(12) = "NN"
NoShow(13) = "NN"
NoShow(14) = "NN"
NoShow(15) = "NN"
NoShow(16) = "NN"
datTestDate = DateSerial(Year(VBA.Date + (8 - Weekday(VBA.Date)) Mod 7 - 3), 1, 1)
intCalendarWeek = (VBA.Date - datTestDate - 3 + (Weekday(datTestDate) + 1) Mod 7) \ 7 + 1 'check out the actual calendar week
If intCalendarWeek < 10 Then
strCalendarWeek = "0" & CStr(intCalendarWeek)
Else
strCalendarWeek = CStr(intCalendarWeek)
End If
For Each r In ActiveProject.Resources
' skip irregular entries
If Not (r Is Nothing) Then
' skip no-show employees
If Not IsInArray(r.Name, NoShow) Then
' skip resource with zero remaining work
If r.RemainingWork > 0 Then
swaFilename = swaPath + swaPrefix + "-" + CStr(Year(VBA.Date)) + "-" + strCalendarWeek + "-" + r.Name + ".xlsx"
' create the excel file and write header
If Not FileExists(swaFilename) Then
' filename is swaPath + year + KW (leading zero) + Name + ".xlsx"
'
Application.StatusBar = "Dumping " + swaFilename
Set excelApp = CreateObject("Excel.Application")
excelApp.Visible = False
Set swaWorkbook = excelApp.Workbooks.Add
Set swaWorksheet = excelApp.Worksheets(1) ' work with first worksheet
' write header: name, date, actual work in hours, ...
swaWorksheet.Cells(1, 1) = "Project"
swaWorksheet.Cells(1, 2) = "Summary Task"
swaWorksheet.Cells(1, 3) = "UID"
swaWorksheet.Cells(1, 4) = "Name"
swaWorksheet.Cells(1, 5) = "Start"
swaWorksheet.Cells(1, 6) = "Finish"
swaWorksheet.Cells(1, 7) = "Work [d]"
swaWorksheet.Cells(1, 8) = "Actual Work [d]"
swaWorksheet.Cells(1, 9) = "Remaining Work [d]"
swaWorksheet.Rows(1).EntireRow.Font.Bold = True
excelApp.ScreenUpdating = False
excelApp.Calculation = xlCalculationManual
i = 1
' now dump all tasks with remaining work > 0
For Each t In ActiveProject.Tasks
If InStr(t.ResourceNames, "[") = 0 Then
realname = t.ResourceNames
Else
realname = Left(t.ResourceNames, InStr(t.ResourceNames, "[") - 1)
End If
If realname = r.Name And t.RemainingWork > 0 Then
i = i + 1
' write info to excel
swaWorksheet.Cells(i, 1) = t.Text28
swaWorksheet.Cells(i, 2) = t.OutlineParent.Name
swaWorksheet.Cells(i, 3) = t.UniqueID
swaWorksheet.Cells(i, 4) = t.Name
swaWorksheet.Cells(i, 5) = t.Start
swaWorksheet.Cells(i, 6) = t.Finish
swaWorksheet.Cells(i, 7) = t.Work / (60 * 8)
swaWorksheet.Cells(i, 8) = t.ActualWork / (60 * 8)
swaWorksheet.Cells(i, 9) = t.RemainingWork / (60 * 8)
' Debug.Print t.Text28; " "; t.OutlineParent.Name; " "; realname; " "; t.Name, t.Start; t.Finish; t.Work / 60; t.ActualWork / 60; t.RemainingWork / 60
' if Finish Date in the same calendar week then highlight the entire row
datTestDate = DateSerial(Year(t.Finish + (8 - Weekday(t.Finish)) Mod 7 - 3), 1, 1)
intCalendarWeekFinish = (t.Finish - datTestDate - 3 + (Weekday(datTestDate) + 1) Mod 7) \ 7 + 1
If intCalendarWeekFinish = intCalendarWeek Then
' Debug.Print realname, intCalendarWeek
swaWorksheet.Rows(i).EntireRow.Interior.ColorIndex = 3 ' finish this week -> red
End If
If intCalendarWeekFinish = intCalendarWeek + 1 Then
' Debug.Print realname, intCalendarWeek
swaWorksheet.Rows(i).EntireRow.Interior.ColorIndex = 6 ' finish next week -> yellow
End If
End If
Next t
' pimp excel file, close excel file and clean up
swaWorkbook.Sheets(1).Columns("A:I").AutoFit
' tricky
excelApp.Goto swaWorkbook.Sheets(1).Range("A2")
excelApp.ActiveWindow.FreezePanes = True
' format columns and stuff
swaWorkbook.Sheets(1).Columns("A").ColumnWidth = 20
swaWorkbook.Sheets(1).Columns("B").ColumnWidth = 70
swaWorkbook.Sheets(1).Columns("C").ColumnWidth = 6
swaWorkbook.Sheets(1).Columns("D").ColumnWidth = 70
swaWorkbook.Sheets(1).Columns("G").NumberFormat = "0.0"
swaWorkbook.Sheets(1).Columns("H").NumberFormat = "0.0"
swaWorkbook.Sheets(1).Columns("I").NumberFormat = "0.0"
'
excelApp.ActiveWorkbook.Sheets(1).Activate ' ugly, but works
With excelApp.ActiveSheet
.AutoFilterMode = False
.Range("A1:I1").AutoFilter
End With
' if on Excel >= 2010 then select all entries and autoformat table
' swaRange = "$A$1:$I$" + CStr(i)
' excelApp.ActiveSheet.ListObjects.Add(xlSrcRange, Range(swaRange), , xlYes).Name = "Tabelle3"
' excelApp.Range("Tabelle3[#All]").Select
' excelApp.ActiveSheet.ListObjects("Tabelle3").TableStyle = "TableStyleMedium2"
' save and exit Excel
excelApp.ScreenUpdating = True
excelApp.Calculation = xlCalculationAutomatic
swaWorkbook.SaveAs swaFilename
swaWorkbook.Close (True)
excelApp.Quit
Else
MsgBox ("File " + swaFilename + " exists. Lets stop here.")
End
End If
End If
End If
End If
Next r
Application.StatusBar = ""
End Sub
