请求获取Excel至MS Project日工时导入宏及清除工时宏排障

实现逻辑 #

对应你提到的映射需求，核心是将Excel中的日期、任务标识、资源标识、每日工时，匹配到MS Project中对应任务分配的日维度时间刻度实际工时。以下是可直接复用的宏代码：

Sub ImportDailyHoursFromExcelToProject()
    Dim projApp As MSProject.Application
    Dim proj As MSProject.Project
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim tsk As MSProject.Task
    Dim res As MSProject.Resource
    Dim asn As MSProject.Assignment
    Dim workDate As Date
    Dim taskName As String
    Dim resName As String
    Dim dailyWork As Double
    
    ' 绑定Excel工作表（替换为你的工时数据所在表名）
    Set ws = ThisWorkbook.Sheets("工时数据")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 连接或启动MS Project
    On Error Resume Next
    Set projApp = GetObject(, "MSProject.Application")
    If Err.Number <> 0 Then
        Set projApp = CreateObject("MSProject.Application")
        projApp.Visible = True
    End If
    On Error GoTo 0
    Set proj = projApp.ActiveProject ' 确保已打开目标Project文件
    
    ' 遍历Excel数据行（第1行假设为表头：日期、任务名称、资源名称、每日工时）
    For i = 2 To lastRow
        workDate = ws.Cells(i, "A").Value
        taskName = ws.Cells(i, "B").Value
        resName = ws.Cells(i, "C").Value
        dailyWork = ws.Cells(i, "D").Value
        
        ' 匹配任务
        Set tsk = Nothing
        For Each tsk In proj.Tasks
            If tsk.Name = taskName Then Exit For
        Next tsk
        If tsk Is Nothing Then GoTo NextRow
        
        ' 匹配资源
        Set res = Nothing
        For Each res In proj.Resources
            If res.Name = resName Then Exit For
        Next res
        If res Is Nothing Then GoTo NextRow
        
        ' 获取或创建任务-资源分配
        Set asn = Nothing
        For Each asn In tsk.Assignments
            If asn.ResourceName = resName Then Exit For
        Next asn
        If asn Is Nothing Then
            Set asn = tsk.Assignments.Add(ResourceID:=res.ID)
        End If
        
        ' 写入对应日期的实际工时（Project工时单位为分钟，需转换）
        Dim tsValues As MSProject.TimeScaleValues
        Set tsValues = asn.TimeScaleData(StartDate:=workDate, EndDate:=workDate, _
            Type:=pjAssignmentTimescaledActualWork, TimeScaleUnit:=pjTimescaleDays)
        If tsValues.Count > 0 Then
            tsValues(1).Value = dailyWork * 60
        End If
        
NextRow:
    Next i
    
    MsgBox "工时导入完成！"
End Sub

注意事项 #

1. 在Excel中需引用MS Project对象库：开发工具→引用→勾选「Microsoft Project xx.x Object Library」
2. Excel表格需对应表头：A列日期、B列任务名称、C列资源名称、D列每日工时（单位：小时）
3. 确保Project中的任务/资源名称与Excel完全匹配，否则会跳过对应行数据

原代码问题分析 #

1. 强制赋值总工时为0：代码中asn.Work = 0会直接将任务分配的总工时设为0，覆盖时间刻度清空后的状态，导致显示0而非空值
2. 时间刻度单位错误：使用pjTimescaleYears会按年维度遍历时间刻度，若项目周期不足一年，无法覆盖所有有工时数据的日期
3. 未处理空任务：遍历任务时未跳过空任务，可能引发运行错误

修正后的代码 #

Sub ClearActualHours()
    Dim tsk As Task
    Dim asn As Assignment
    Dim projStart As Date
    Dim projEnd As Date
    Dim TSValues As TimeScaleValues
    Dim tsv As TimeScaleValue
    
    projStart = ActiveProject.ProjectStart
    projEnd = ActiveProject.ProjectFinish
    
    For Each tsk In ActiveProject.Tasks
        If Not tsk Is Nothing Then ' 跳过空任务
            For Each asn In tsk.Assignments
                ' 保留特定分配的判断（若需清除所有分配，可删除此if块）
                If asn.UniqueID = 2097154 Then
                    ' 按日维度遍历时间刻度，确保覆盖所有日期
                    Set TSValues = asn.TimeScaleData(projStart, projEnd, _
                        pjAssignmentTimescaledActualWork, pjTimescaleDays)
                    For Each tsv In TSValues
                        tsv.Clear
                    Next tsv
                    
                    ' 清空实际工时字段，而非强制设为0
                    asn.ActualWork = Empty
                End If
            Next asn
        End If
    Next tsk
End Sub

修正说明 #

• 移除asn.Work = 0的强制赋值，改用asn.ActualWork = Empty清空实际工时字段
• 将时间刻度单位改为pjTimescaleDays，确保遍历到所有有工时数据的日期
• 添加If Not tsk Is Nothing判断，避免空任务引发错误
• 保留了特定分配的UniqueID判断，若需清除所有任务分配的实际工时，可删除该判断块

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