修复MS Project转Excel宏中ActualHours显示为0的问题

现有VBA宏用于将MS Project数据传输至Excel，但实际工时（ActualHours）始终显示为0，以下是具体修复方案：

问题根源分析 #

• 常量拼写错误：原代码中pjAssignmentTimescalendWork拼写错误，正确应为pjAssignmentTimescaledWork
• 取错数据类型：原代码获取的是计划工时（Work），而非实际工时（ActualWork），需替换为对应的常量
• 错误处理逻辑失效：On Error GoTo 0会重置错误状态，导致无法正确捕获TimeScaleData的调用错误
• 多资源分配工时被覆盖：循环多个任务分配时，同一单元格的工时会被最后一个分配的值覆盖，需累加计算
• 日期匹配效率低：嵌套循环查找日期列的逻辑冗余，可优化为直接计算列索引

修复步骤 #

1. 修正常量定义：
   • 修正拼写错误的计划工时常量
   • 添加实际工时对应的常量pjAssignmentTimescaledActualWork
2. 替换数据类型常量：调用TimeScaleData时，使用实际工时常量获取真实的实际工时数据
3. 修复错误处理：调整错误处理语句的顺序，确保能正确捕获并处理TimeScaleData的调用异常
4. 累加多资源工时：对同一任务的多个资源分配，累加每日实际工时，避免覆盖
5. 优化日期列查找：通过日期差直接计算Excel列索引，替代嵌套循环查找

完整修正代码 #

Sub TransferProjectData_WithDateRange()
    ' -----------------------------------------------
    '  声明与初始化
    ' -----------------------------------------------
    Const pjAssignmentTimescaledWork As Long = 7 ' 修正拼写错误
    Const pjAssignmentTimescaledActualWork As Long = 10 ' 实际工时常量
    Const pjTimescaleDays As Long = 0
    Dim projApp As MSProject.Application
    Dim proj As MSProject.Project
    Dim tsk As MSProject.Task
    Dim olApp As Object
    Dim olWb As Object
    Dim olWs As Object
    Dim col As Long
    Dim taskStartDate As Date, taskEndDate As Date, currentDate As Date
    Dim headerDate As Date
    Dim dailyActualEffort As Double ' 用于累加每日实际工时
    Dim wsRow As Long
    Dim minDate As Date, maxDate As Date
    Dim assn As MSProject.Assignment
    Dim timeScaleValues As Variant
    Dim dateDiffDays As Long ' 日期差计算列索引

    ' -----------------------------------------------
    ' 获取活动MS Project文件
    ' -----------------------------------------------
    On Error Resume Next
    Set projApp = GetObject(, "MSProject.Application")
    On Error GoTo 0
    If projApp Is Nothing Then
        MsgBox "请先打开MS Project文件"
        Exit Sub
    End If
    Set proj = projApp.ActiveProject
    If proj Is Nothing Then
        MsgBox "未找到活动的MS Project文件"
        Exit Sub
    End If

    ' -----------------------------------------------
    ' 获取或创建Excel应用
    ' -----------------------------------------------
    On Error Resume Next
    Set olApp = GetObject(, "Excel.Application")
    On Error GoTo 0
    If olApp Is Nothing Then
        Set olApp = CreateObject("Excel.Application")
        olApp.Visible = True
    End If

    ' -----------------------------------------------
    ' 初始化Excel工作簿与工作表
    ' -----------------------------------------------
    On Error Resume Next
    Set olWb = olApp.Workbooks("ProjectData.xlsx")
    On Error GoTo 0
    If olWb Is Nothing Then
        Set olWb = olApp.Workbooks.Add
        olWb.SaveAs FileName:="ProjectData.xlsx"
    End If
    On Error Resume Next
    Set olWs = olWb.Sheets("ProjectData")
    On Error GoTo 0
    If olWs Is Nothing Then
        Set olWs = olWb.Sheets.Add
        olWs.Name = "ProjectData"
    End If

    ' -----------------------------------------------
    ' 确定项目的最小/最大日期
    ' -----------------------------------------------
    minDate = proj.ProjectFinish
    maxDate = proj.ProjectStart
    For Each tsk In proj.Tasks
        If Not tsk Is Nothing And Not tsk.Summary Then ' 排除摘要任务
            If tsk.Start < minDate Then minDate = tsk.Start
            If tsk.Finish > maxDate Then maxDate = tsk.Finish
        End If
    Next tsk

    ' -----------------------------------------------
    ' 生成Excel表头
    ' -----------------------------------------------
    olWs.Cells(1, 1).Value = "任务名称"
    olWs.Cells(1, 2).Value = "总计划工时(小时)"
    olWs.Cells(1, 3).Value = "总实际工时(小时)" ' 新增实际工时列
    olWs.Cells(1, 4).Value = "工期"
    olWs.Cells(1, 5).Value = "开始日期"
    olWs.Cells(1, 6).Value = "结束日期"
    ' 生成日期表头（从G列开始）
    col = 7
    headerDate = minDate
    Do While headerDate <= maxDate
        olWs.Cells(1, col).Value = headerDate
        olWs.Cells(1, col).NumberFormat = "dd.mm.yyyy"
        headerDate = DateAdd("d", 1, headerDate)
        col = col + 1
    Loop

    ' -----------------------------------------------
    ' 遍历MS Project任务并写入Excel
    ' -----------------------------------------------
    wsRow = 2
    For Each tsk In proj.Tasks
        If Not tsk Is Nothing And Not tsk.Summary Then ' 跳过摘要任务
            taskStartDate = tsk.Start
            taskEndDate = tsk.Finish
            ' 写入基础任务数据
            olWs.Cells(wsRow, 1).Value = tsk.Name
            olWs.Cells(wsRow, 2).Value = tsk.Work / 60 ' 计划工时转小时
            olWs.Cells(wsRow, 3).Value = tsk.ActualWork / 60 ' 总实际工时转小时
            olWs.Cells(wsRow, 4).Value = tsk.Duration
            olWs.Cells(wsRow, 5).Value = taskStartDate
            olWs.Cells(wsRow, 5).NumberFormat = "dd.mm.yyyy"
            olWs.Cells(wsRow, 6).Value = taskEndDate
            olWs.Cells(wsRow, 6).NumberFormat = "dd.mm.yyyy"

            ' 遍历任务的每日日期，写入实际工时
            currentDate = taskStartDate
            Do While currentDate <= taskEndDate
                ' 通过日期差直接计算Excel列索引（避免嵌套循环）
                dateDiffDays = DateDiff("d", minDate, currentDate)
                excelCol = 7 + dateDiffDays ' 日期列从G列开始
                dailyActualEffort = 0 ' 初始化每日实际工时累加值

                ' 遍历任务的所有资源分配，累加实际工时
                For Each assn In tsk.Assignments
                    On Error Resume Next
                    ' 获取当日实际工时（使用ActualWork常量）
                    Set timeScaleValues = assn.TimeScaleData(currentDate, currentDate, pjAssignmentTimescaledActualWork, pjTimescaleDays)
                    On Error GoTo 0
                    
                    If Not timeScaleValues Is Nothing Then
                        If timeScaleValues.Count > 0 Then
                            ' 分钟转小时并累加
                            dailyActualEffort = dailyActualEffort + (timeScaleValues(1).Value / 60)
                        End If
                        Set timeScaleValues = Nothing ' 释放对象
                    End If
                Next assn

                ' 写入累加后的每日实际工时
                olWs.Cells(wsRow, excelCol).Value = dailyActualEffort
                ' 日期步进
                currentDate = DateAdd("d", 1, currentDate)
            Loop
            wsRow = wsRow + 1
        End If
    Next tsk

    ' -----------------------------------------------
    ' 清理对象
    ' -----------------------------------------------
    Set proj = Nothing
    Set projApp = Nothing
    Set tsk = Nothing
    Set olWs = Nothing
    Set olWb = Nothing
    Set olApp = Nothing
    MsgBox "数据传输完成！"
End Sub

关键修复点说明 #

• 实际工时常量：使用pjAssignmentTimescaledActualWork（值为10）替代计划工时常量，确保获取的是实际已完成的工时数据
• 错误处理优化：将On Error GoTo 0移至对象判断之后，避免重置错误状态导致无法捕获异常
• 工时累加：新增dailyActualEffort变量，对同一任务的多个资源分配进行工时累加，避免覆盖
• 列索引优化：通过DateDiff计算日期差直接定位Excel列，提升运行效率
• 排除摘要任务：在遍历任务时添加Not tsk.Summary判断，避免处理无实际工时的摘要任务

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