从MS Project导出每日资源任务工时至Excel的VBA问题

我需要从MS Project生成Excel表格，遍历项目起止日期，按日期升序输出每日各资源在当日排期任务上的分配工时。但当前编写的VBA代码输出的是任务总工时，而非每日工时，期望实现类似day.task.resource.work的逻辑来获取每日工时。

原代码如下：

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 <= prjFinish
        dateArray(counter) = dateLoop
        dateLoop = DateAdd("d", 1, dateLoop)
        counter = counter + 1
    Loop

    ' Get existing instance of Excel, or start Excel if not running
    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, _
                "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 <= prjFinish

        'task iterator
        For Each tsk In tsksList
            If tsk.Start = prjDate And tsk.ResourceNames <> "" 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

核心是利用MS Project的Assignment.TimeScaleData方法，该方法可以获取资源在指定时间段内的分时数据（包括每日工时）。修改后的代码如下：

Option Explicit
    
Sub ExportDailyResourceWork()
    Dim xl As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim xlRange As Excel.Range
    Dim tsk As Task
    Dim assn As Assignment
    Dim prjStart As Date, prjFinish As Date, currentDate As Date
    Dim timeScaleData As TimeScaleValues
    Dim tsValue As TimeScaleValue
    
    ' 初始化日期范围（可保留测试用的固定日期）
    prjStart = ActiveProject.ProjectStart
    prjFinish = ActiveProject.ProjectFinish
    ' 测试用固定日期
    prjStart = #12/2/2022 8:00:00 AM#
    prjFinish = #12/22/2022 8:00:00 AM#
    
    ' 启动或连接Excel
    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，请检查是否安装", vbCritical
            Exit Sub
        End If
    End If
    On Error GoTo 0
    
    ' 创建Excel工作簿和工作表
    Set xlBook = xl.Workbooks.Add
    Set xlSheet = xlBook.ActiveSheet
    xl.Visible = True
    xl.ScreenUpdating = True
    
    ' 设置表头
    With xlSheet.Range("A1:C1")
        .Value = Array("日期", "资源", "当日工时")
        .Font.Bold = True
        .VerticalAlignment = xlVAlignCenter
    End With
    Set xlRange = xlSheet.Range("A2")
    
    ' 遍历每个日期
    currentDate = prjStart
    Do While currentDate <= prjFinish
        ' 遍历所有任务
        For Each tsk In ActiveProject.Tasks
            ' 跳过摘要任务和无资源分配的任务
            If Not tsk.Summary And tsk.Assignments.Count > 0 Then
                ' 遍历任务的每个资源分配
                For Each assn In tsk.Assignments
                    ' 获取该资源在当日的工时数据
                    Set timeScaleData = assn.TimeScaleData( _
                        StartDate:=currentDate, _
                        EndDate:=currentDate, _
                        Type:=pjAssignmentTimescaledWork, _
                        TimeScaleUnit:=pjTimescaleDays)
                    
                    ' 提取当日工时
                    For Each tsValue In timeScaleData
                        If tsValue.Value > 0 Then
                            xlRange.Value = Array( _
                                Format(currentDate, "yyyy/mm/dd"), _
                                assn.ResourceName, _
                                tsValue.Value / 60 ' 转换为小时（MS Project默认存储为分钟）
                            )
                            Set xlRange = xlRange.Offset(1, 0)
                        End If
                    Next tsValue
                Next assn
            End If
        Next tsk
        
        ' 日期自增
        currentDate = DateAdd("d", 1, currentDate)
    Loop
    
    ' 自动调整列宽
    xlSheet.Range("A:C").EntireColumn.AutoFit
    
    ' 清理对象
    Set xlRange = Nothing
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xl = Nothing
    
    ActiveWindow.Caption = ActiveProject.Name
End Sub

关键修改说明 #

• 遍历资源分配（Assignments）：不再直接使用任务的ResourceNames，而是遍历每个任务的Assignments集合，确保每个资源单独输出一行
• 使用TimeScaleData获取每日工时：通过assn.TimeScaleData方法指定日期范围为当日，类型为pjAssignmentTimescaledWork，单位为天，精准获取当日工时
• 工时单位转换：MS Project中工时默认以分钟存储，除以60转换为小时（可根据需求调整）
• 跳过无效任务：增加了跳过摘要任务和无资源分配任务的判断，避免无效数据
• 优化Excel对象引用：直接引用工作表对象，减少不必要的Range跳转，提升代码效率

内容的提问来源于stack exchange，提问作者Derrick Robinson