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