VBA MS Project output 每天每个任务每个资源的小时数到 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 (ie 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