VBA MS Project output hours per resource per task per day to Excel - excel

Question

I'm trying to create an Excel spreadsheet from MS Project that will iterate through the project start to finish dates, & for each date (in ascending sequence from the start) output the amount of work hours each resource is assigned for each task that is scheduled to take place on that day, like this:
Excel output from MS Project
I've almost managed to get it working to some extent, but am struggling with showing the number of hours worked PER DAY, as opposed to the whole amount of work hours for the task (which is what it's currently doing).
Option Explicit
Sub exportViaArray()
' Declare in memory
Dim xl As Excel.Application
Dim XLbook As String
Dim xlRange As Excel.Range
Dim tsk As Task
Dim tsksList As Tasks
Dim person As Resource
Dim resList As Resources
Dim prjStart As Date, prjFinish As Date, prjDate As Date, dateLoop As Date, dateArray() As Date
Dim counter As Integer
Dim totalDates As Long
Dim day As Variant
' Define variable values
prjStart = ActiveProject.ProjectStart
prjFinish = ActiveProject.ProjectFinish
Set tsksList = ActiveProject.Tasks
Set resList = ActiveProject.Resources
' assigning the project start date for loop var prjDate
prjDate = prjStart
' assign specific dates, for dev/testing
prjStart = "02/12/2022 08:00:00"
prjFinish = "22/12/2022 08:00:00"
' prjDate = "12/12/2022 08:00:00"
' create an array of dates to iterate through
totalDates = DateDiff("d", prjStart, prjFinish)
ReDim dateArray(totalDates)
counter = 0
dateLoop = prjStart
Do While dateLoop 0 Then
On Error GoTo 0
Set xl = CreateObject("Excel.Application")
If Err 0 Then
MsgBox "Excel application is not available on this workstation" _
& vbCr & "Install Excel or check network connection", vbCritical, _
"Notes Text Export - Fatal Error"
FilterApply Name:="all tasks"
Set xl = Nothing
On Error GoTo 0 'clear error function
Exit Sub
End If
End If
On Error GoTo 0
xl.Workbooks.Add
XLbook = xl.ActiveWorkbook.Name
' Keeping these True for dev/testing
xl.Visible = True
xl.ScreenUpdating = True
xl.DisplayAlerts = True
ActiveWindow.Caption = " Writing data to worksheet"
' Excel - create column headings
Set xlRange = xl.Range("A1")
xlRange.Range("A1") = "Date"
xlRange.Range("B1") = "Resource"
xlRange.Range("C1") = "Duration"
' Set all column headers
With xlRange.Range("A1:C1")
.Font.Bold = True
.VerticalAlignment = xlVAlignCenter
End With 'XLrange
' Export Schedule Report Information
Set xlRange = xlRange.Range("A2")
' date iterator
Do While prjDate "" Then
With xlRange
.Range("A1") = Format(tsk.Start, "short Date")
.Range("B1") = tsk.ResourceNames
.Range("C1") = tsk.Duration
End With
' Go to next row in Excel
Set xlRange = xlRange.Offset(1, 0)
End If
Next tsk
'increment date
prjDate = DateAdd("d", 1, prjDate)
'check current loop date is not greater than end date
If prjDate > prjFinish Then
Exit Do
End If
Loop
xlRange.Range("A1:C1").EntireColumn.AutoFit
Set xl = Nothing
' Reset window to project name
ActiveWindow.Caption = ActiveProject.Name
End Sub
I'm not a developer, but can generally hack stuff together to get a result, & I'm sure there's errors in the above, but this last piece of the puzzle has really got me.
I was hoping it'd be something along the lines of using something like this: day.task.resource.work but I've tried & can't get that to work.
Any help would be greatly appreciated.
Cheers!

Answer 1

Derrick, you need to export timescaled data (i.e. Project's Resource Usage view). It sounds like you are trying to export static data. This code should get you started with a few tweaks to export resource hours instead of % allocation. I'll leave that as an "exercise for the student." But, if you need more help, I'll be available.
'Exports resource and assignment percent allocation
'Author: John-Project
'Initial release: 7/6/21 11:00 AM
Option Explicit
Public Const ver = " 1.0"
Public xl As Excel.Application
Public WS1 As Worksheet, WS2 As Worksheet
Public xlRange As Range
Public TotMon As Integer
Public PrSt As Date, PrFi As Date, Dat As Date
Public i As Integer, j As Integer, p1 As Integer, Delta As Integer
Public k As Long, TimSt As Long, TotTim As Long
Sub ExportFTEdata()
Dim r As Resource
Dim a As Assignment
Dim ResSt As Date, ResFin As Date
Dim TSV1 As TimeScaleValues
'opening user interface
MsgBox "This macro exports Monthly FTE data (% Allocation)" & vbCr _
& "by resource and resource assignments to a new Excel Workbook." & vbCr _
& vbCr & "When complete the user will be shown an Excel Save As prompt", _
vbInformation, "Timescale Export - ver" & ver
'find start and finish of plan to establish index reference for weekly values
PrSt = ActiveProject.ProjectStart
PrFi = ActiveProject.ProjectFinish
TotMon = DateDiff("m", PrSt, PrFi)
'set up an new instance of Excel, or if Excel is not running, start it
On Error Resume Next
Set xl = GetObject(, "Excel.application")
If Err <> 0 Then
On Error GoTo 0
Set xl = CreateObject("Excel.Application")
If Err <> 0 Then
MsgBox "Excel application is not available on this workstation" _
& vbCr & "Install Excel or check network connection", vbCritical, _
"Project Data Export - Fatal Error"
FilterApply Name:="all tasks"
Set xl = Nothing
On Error GoTo 0 'clear error function
Exit Sub
End If
End If
On Error GoTo 0
'create a workbook with two worksheets
xl.Workbooks.Add
xl.ActiveWorkbook.Worksheets(1).Name = "FTE Data"
Set WS1 = xl.ActiveWorkbook.Worksheets(1)
'Keep Excel in the background and minimized until spreadsheet is done (speeds transfer)
xl.Visible = True
xl.ScreenUpdating = True
xl.DisplayAlerts = False
TimSt = Timer 'capture start time of export
'pre-format worksheet
ShFormat1
'Populate monthly data worksheet
Set xlRange = WS1.Range("C2")
'initialize worksheet row counter
i = 0
For Each r In ActiveProject.Resources
xlRange.Offset(i, -2) = r.Name
If r.Assignments.Count > 0 Then
'resource start and finish fields are not directly readable with VBA
' so need to cycle through all assignments and find earliest and latest
ResSt = "12/31/2049": ResFin = "1/1/1984"
For Each a In r.Assignments
If a.Start < ResSt Then ResSt = a.Start
If a.Finish > ResFin Then ResFin = a.Finish
Next a
'determine resource start offset from project start
Delta = DateDiff("m", PrSt, ResSt)
'write monthly percent allocation values for resource
Set TSV1 = r.TimeScaleData(StartDate:=ResSt, EndDate:=ResFin, _
Type:=pjResourceTimescaledPercentAllocation, timescaleunit:=pjTimescaleMonths)
p1 = Delta 'set column start pointer
For k = 1 To TSV1.Count
If IsNumeric(TSV1(k)) Then
xlRange.Offset(i, p1).Value = Round(TSV1(k).Value, 0) & "%"
End If
p1 = p1 + 1
Next k
'increment row and reset start pointer
i = i + 1
'write monthly percent allocation vlaues for assignments
For Each a In r.Assignments
'reset start pointer for this assignment
Delta = DateDiff("m", PrSt, a.Start)
p1 = Delta
xlRange.Offset(i, -1).Value = a.TaskName
Set TSV1 = a.TimeScaleData(StartDate:=a.Start, EndDate:=a.Finish, _
Type:=pjAssignmentTimescaledPercentAllocation, timescaleunit:=pjTimescaleMonths)
For k = 1 To TSV1.Count
If IsNumeric(TSV1(k)) Then
xlRange.Offset(i, p1).Value = Round(TSV1(k).Value, 0) & "%"
End If
p1 = p1 + 1
Next k
i = i + 1 'next assignment row
Next a
Else
'no assignments for this resource so increment to next row
i = i + 1
End If
Next r
'format completed worksheet
xl.Visible = True
WS1.Activate
WS1.UsedRange.Columns.AutoFit
WS1.Rows(2).Select
xl.ActiveWindow.FreezePanes = True
TotTim = Timer - TimSt
xl.Visible = False
MsgBox "Export is complete" & vbCr & _
" Export time: " & TotTim & " sec", vbInformation
xl.Visible = True
xl.GetSaveAsFilename InitialFileName:="Resource Tracking"
Set xl = Nothing
End Sub
'subroutine to pre-format worksheet
Sub ShFormat1()
WS1.Range("A1") = "Resource Name"
WS1.Range("B1") = "Assignment"
Set xlRange = WS1.Range("B1")
Dat = PrSt
'write weekly dates starting with cell B1 offset by i index
For i = 1 To TotMon
xlRange.Offset(0, i).Value = Format(Dat, "mmm-yy")
Dat = DateAdd("m", 1, Dat)
Next i
WS1.Rows(1).Font.Bold = True
End Sub