MS Project VBA宏更新pjAssignmentTimescaledWork值时自动修改问题排查

功能概述 #

开发一款MS Project VBA宏，实现以下功能：

• 读取存储资源任务剩余工时的CSV文件
• 根据剩余工时计算任务起止日期
• 通过计算每日工时与天数，更新对应任务、资源及分配的pjAssignmentTimescaledWork类型TimeScaleValues
• 任务起止日期、每日工时等参数会依据任务是否已存在、读取排序数据时任务是否变更采用差异化计算逻辑

问题现象 #

• 单条数据运行时，代码完全符合预期
• 添加同任务不同资源的第二条数据后：
  • 第二条数据的工时存储正确
  • 第一条已正确写入的数值被修改（例如两条数据均为2小时，单条运行时第一条为2小时，两条同时运行时第一条变为0.4）
• 若在处理第二条数据前中断代码，第一条数据的工时仍保持2小时
• 最初尝试直接设置任务起止日期并更新分配的RemainingHours时，也出现相同的数值被修改问题

目标需求 #

实现每条数据的剩余工时Work值更新正确，不受其他数据处理的影响

代码实现 #

Sub ImportTimesheetDataProjected()

    Dim proj As Project
    Set proj = Application.ActiveProject
    Set xlApp = New Excel.Application

    Dim filePath As Variant
    Dim fd As FileDialog

    Set fd = xlApp.FileDialog(msoFileDialogFilePicker)

    fd.Title = "Select data file"
    fd.Filters.Clear
    fd.Filters.Add "CSV Files", "*.csv", 1
    fd.Show
    filePath = fd.SelectedItems(1)

    If filePath <> "" Then

        Application.Calculation = pjManual
        Application.ScreenUpdating = False

        ReadTimesheetDataAndUpdateProject proj, filePath

        Application.Calculation = pjAutomatic
        Application.ScreenUpdating = True
    
        MsgBox "Timesheet data updated successfully.", vbInformation
    Else
        MsgBox "No file selected. Operation canceled.", vbInformation
    End If
End Sub

Sub ReadTimesheetDataAndUpdateProject(proj As Project, filePath As Variant)

    Dim excelApp As Object
    Set excelApp = CreateObject("Excel.Application")

    Dim wb As Excel.Workbook
    Set wb = excelApp.Workbooks.Open(filePath)

    Dim ws As Excel.Worksheet
    Set ws = wb.Worksheets(1)

    'Time data sorting code omitted

    Dim rowIndex As Long
    Dim lastRowIndex As Long
    lastRowIndex = ws.Cells(ws.Cells.Rows.Count, 1).End(-4162).Row

    Dim taskName As String
    Dim prevTaskName As String
    prevTaskName = ""
    Dim task As task
    Dim resourceName As String
    Dim prevResourceName As String
    Dim assignment As assignment
    Dim resource As resource
    Dim ts As TimeScaleValues
    Dim tsIndex As Long
    Dim startDate As Date
    Dim endDate As Date
    Dim found As Boolean
    Dim workingDays As Long
    Dim totalDays As Long
    Dim hoursPerDay As Variant
    Dim lastCellFlag As Boolean

    rowIndex = 2
    Do While rowIndex <= lastRowIndex
        taskName = ws.Cells(rowIndex, 2).Value & " - " & ws.Cells(rowIndex, 3).Value & " - " & ws.Cells(rowIndex, 4).Value
        resourceName = ws.Cells(rowIndex, 5).Value
    
        If ws.Cells(rowIndex, 6).Value > 0 Then

            If taskName <> prevTaskName Then

                workingDays = excelApp.WorksheetFunction.RoundUp(ws.Cells(rowIndex, 6).Value / 7.6, 0)
            
                found = Find(Field:="Name", Test:="equals", Value:=taskName)

                If found Then
                    Set task = ActiveCell.task
                    startDate = Int(proj.StatusDate + 1)
                    totalDays = getTotalDays(workingDays, startDate)
                    If startDate + totalDays > task.Finish Then
                        endDate = startDate + totalDays
                        task.Finish = endDate
                        hoursPerDay = 7.6
                        lastCellFlag = True
                    Else
                        endDate = Int(task.Finish)
                        hoursPerDay = ws.Cells(rowIndex, 6).Value / getWorkingDays(startDate, endDate)
                        lastCellFlag = False
                    End If

                Else
                    Set task = proj.Tasks.Add(taskName)
                    task.Type = pjFixedWork
                    startDate = Date
                    task.Start = startDate
                    totalDays = getTotalDays(workingDays, startDate)
                    endDate = Date + totalDays
                    task.Finish = endDate
                    hoursPerDay = 7.6
                    lastCellFlag = True
                End If
            Else
                totalDays = getTotalDays(workingDays, startDate)
                If startDate + totalDays > task.Finish Then
                    endDate = Int(startDate + totalDays)
                    task.Finish = endDate
                    hoursPerDay = 7.6
                    lastCellFlag = True
                Else
                    hoursPerDay = ws.Cells(rowIndex, 6).Value / getWorkingDays(startDate, endDate)
                    lastCellFlag = False
                End If
            End If
        
            Set resource = FindOrCreateResource(proj, resourceName)
            Set assignment = FindOrAddResourceToTask(task, resource)
            Set ts = assignment.TimeScaleData(startDate:=startDate, endDate:=endDate, Type:=pjAssignmentTimescaledWork, TimeScaleUnit:=pjTimescaleDays)
            tsIndex = 1
            Do While tsIndex < ts.Count
                If Format(ts(tsIndex).startDate, "ddd") <> "Sat" And Format(ts(tsIndex).startDate, "ddd") <> "Sun" Then
                    ts(tsIndex).Value = hoursPerDay * 60
                End If
                tsIndex = tsIndex + 1
            Loop
            If lastCellFlag Then
                ts(tsIndex).Value = (((ws.Cells(rowIndex, 6).Value * 100) Mod 760) / 100) * 60
            Else
                ts(tsIndex).Value = hoursPerDay * 60
            End If
        
            prevTaskName = taskName
        End If

        rowIndex = rowIndex + 1
    
    Loop

    wb.Save
    wb.Close

    excelApp.Quit
End Sub

Function FindOrCreateResource(proj As Project, resourceName As String) As resource
    Dim resource As resource
    Dim found As Boolean

    For Each res In proj.Resources
        If res.Name = resourceName Then
            Set resource = res
            Exit For
        End If
    Next res

    If resource Is Nothing Then
        Set resource = proj.Resources.Add(resourceName)
    End If

    Set FindOrCreateResource = resource
End Function

Function FindOrAddResourceToTask(task As task, resource As resource) As assignment
    For Each assignment In task.Assignments
        If assignment.resourceName = resource.Name Then
            Set FindOrAddResourceToTask = assignment
            Exit Function
        End If
    Next assignment

    Set FindOrAddResourceToTask = task.Assignments.Add(ResourceID:=resource.ID)
End Function

Function getTotalDays(totalDays As Long, startDate As Date) As Long

    Dim i As Long
    i = 0
    Do While i < totalDays
        If Format(startDate + i, "ddd") = "Sat" Or Format(startDate + i, "ddd") = "Sun" Then
           totalDays = totalDays + 1
        End If
        i = i + 1
    Loop

    getTotalDays = totalDays

End Function

Function getWorkingDays(startDate As Date, endDate As Date) As Long
    Dim totalDays As Long
    Dim workingDays As Long
    Dim i As Long
    totalDays = DateDiff("d", startDate, endDate)
    workingDays = totalDays
    i = 0
    Do While i < totalDays
        If Format(startDate + i, "ddd") = "Sat" Or Format(startDate + i, "ddd") = "Sun" Then
            workingDays = workingDays - 1
        End If
        i = i + 1
    Loop

    getWorkingDays = workingDays

End Function

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