使用VBA提取MS Project基准工时出现数值异常问题求助

2023年11月20日更新（补充代码与测试场景） #

所用VBA代码片段 #

Set tsvs = Tsk.TimeScaleData(Tsk.Start, Tsk.Finish, pjTaskTimescaledCost, pjTimescaleMonths)
Set tsvs1 = Tsk.TimeScaleData(Tsk.Start, Tsk.Finish, pjTaskTimescaledWork, pjTimescaleMonths)
Set tsvs2 = Tsk.TimeScaleData(Tsk.Start, Tsk.Finish, pjTaskTimescaledBaselineWork, pjTimescaleMonths)

For Each tsv In tsvs
    xlRange.Value = Tsk.UniqueID
    xlRange.Offset(0, 1) = Tsk.Id
    xlRange.Offset(0, 2) = Tsk.Name
    xlRange.Offset(0, 3) = Tsk.GetField(FieldNameToFieldConstant("Project")) 'Project name
    xlRange.Offset(0, 4) = Tsk.Duration / 480 'duration in days                               
    xlRange.Offset(0, 6) = tsv.StartDate    ' Period
    xlRange.Offset(0, 5) = tsv.Value        ' Planned Cost ($)

    'Calculate Planned Work (hrs) for time phased data
    If tsvs1.Item(tsv.Index).Value = "" Then
       xlRange.Offset(0, 6) = 0 
    Else
       xlRange.Offset(0, 6) = (tsvs1.Item(tsv.Index).Value) / 60 ' Planned Work (hrs)
    End If

    'Calculate Baseline Work (hrs) for time phased data
    If tsvs2.Item(tsv.Index).Value = "" Then
       xlRange.Offset(0, 7) = 0
    Else
       xlRange.Offset(0, 7) = (tsvs2.Item(tsv.Index).Value) / 60 ' Baseline Work (hrs)
    End If
Next

测试场景 #

• 创建含5个任务的项目，所有任务为固定工时类型，每个任务分配76工时，工期10天
• 保存基准后，将任务2的工期修改为20天
• 提取数据时发现基准工时发生异常变化

原始问题背景与异常现象 #

背景 #

使用VBA脚本按月度时间分段提取基准工时，设置基准后脚本输出数值正常。保存基准后，因延误事件修改部分任务的开始日期（未修改基准），用于项目进度跟踪。

异常现象 #

• 修改任务开始日期后，提取的时间分段基准工时从延误日期开始数值减少
• MS Project的任务使用视图、资源使用视图中基准工时显示正常
• 计划工时提取无异常

解决思路 #

1. 修正基准工时的查询时间范围
   当前代码用任务修改后的Start和Finish作为基准工时的查询区间，但基准工时的时间分段是基于基准计划的时间范围，而非修改后的任务时间。应改为使用任务的基准起止日期：

   Set tsvs2 = Tsk.TimeScaleData(Tsk.BaselineStart, Tsk.BaselineFinish, pjTaskTimescaledBaselineWork, pjTimescaleMonths)
   

2. 替换索引匹配为日期匹配
   依赖tsvs.Index匹配三个时间分段集合的项，若基准与当前任务的时间范围不一致，会导致索引错位取错值。建议改为按日期匹配对应项：

   ' 遍历基准工时集合而非成本集合
   For Each tsvBaseline In tsvs2
       ' 匹配对应日期的成本、计划工时项
       Dim tsvCost As TimeScaleValue, tsvWork As TimeScaleValue
       Set tsvCost = GetTimeScaleValueByDate(tsvs, tsvBaseline.StartDate)
       Set tsvWork = GetTimeScaleValueByDate(tsvs1, tsvBaseline.StartDate)
       
       ' 后续赋值逻辑基于匹配到的项处理
       If Not tsvCost Is Nothing Then
           xlRange.Offset(0, 5) = tsvCost.Value
           xlRange.Offset(0, 6) = tsvCost.StartDate
       End If
       ' 计划工时、基准工时赋值逻辑同理
       xlRange.Offset(0, 7) = tsvBaseline.Value / 60
       
       Set xlRange = xlRange.Offset(1, 0)
   Next
   

   辅助匹配函数：

   Function GetTimeScaleValueByDate(tsvs As TimeScaleValues, targetDate As Date) As TimeScaleValue
       For Each tsv In tsvs
           If tsv.StartDate = targetDate Then
               Set GetTimeScaleValueByDate = tsv
               Exit Function
           End If
       Next
       Set GetTimeScaleValueByDate = Nothing
   End Function
   

3. 验证基准总工时是否正常
   先确认任务的总基准工时未被意外修改，通过VBA输出验证：

   Debug.Print Tsk.BaselineWork / 60 ' 固定工时任务应输出初始设置的76
   

   若总工时异常，需排查是否误触了基准更新操作；若总工时正常，问题则出在时间分段数据的提取逻辑。

4. 缩小时间刻度范围排查
   暂时将时间刻度从pjTimescaleMonths改为pjTimescaleDays，观察提取的基准工时是否正常，以此排除月度边界对齐导致的截取异常。

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