Microsoft Project - 从 Excel 电子表格导入资源费率

Question

我收到了一份电子表格，其中列出了未来十年每个财政年度的一些资源和资源费率。每年从 5 月 1 日开始。

每个月这些费率都有可能发生变化，例如，可能有人升职，他们的费率也会发生变化。

我正在尝试找出一种方法，可以将资源费率从 Excel 电子表格导入 Microsoft Project 中的资源表，并更新资源费率表 A 以反映每个财政年度的新费率（例如未来十年）。

我知道我需要一个宏来执行此操作，但我不确定从哪里开始。导入映射似乎不起作用。

我的出发点是使用这段代码

Sub SetRateAfromEntField()

    'Declare Variables
    Dim Res As Resource

    'Loop All Resources
    For Each Res In ActiveProject.Resources
    
        'Check for Real Resource
        If Not (Res Is Nothing) Then
               
            'Set Rate Table A from Std. Rate A
            Res.CostRateTables(1).PayRates(Res.CostRateTables(1).PayRates.Count).StandardRate = Res.GetField(FieldNameToFieldConstant("Std. Rate A", pjResource))
            
        End If
           
    Next Res
    
End Sub

并假设存在已包含费率的资源自定义字段，因此我需要十个自定义字段。

但是，在我的情况下，数据位于 Excel 工作表中。每个资源都有一个唯一的参考代码 (resCode)，它存在于 Excel 工作表和每个资源的资源池中。

我正在尝试找出一种方法来直接从电子表格中读取费率并定期更新资源费率。

我看到这段代码看起来很接近，但不包括对存储在 Excel 电子表格中的数据的引用，需要从中读取费率。 https://pm.stackexchange.com/questions/25019/ms-project-multi-year-inflation

总结：

未来 10 年每年的资源费率存储在电子表格中。

资源在 Excel 工作表和项目中都唯一地映射到资源代码 (resCode)。

每月需要通过运行宏导入费率来更新费率。

我们将不胜感激地收到有关如何最好地实现这一目标的任何帮助。

Answer 1

我相信您希望能够从这样的电子表格中导入费率：

在本例中，资源名称列在 A 列，费率生效日期列在第 1 行，费率值是资源名称和生效日期的交集。

我正在假设具有这些完全相同名称的资源存在于我要将费率导入到的 MS 项目文件的资源表中。

这是用 Excel VBA 编写的代码：

Sub ImportRatesToAProject()

    'Using late binding on MS Project objects since code is being written in Excel VBA
    Dim res As Object 'Resource
    Dim prjApp As Object

    Set prjApp = GetObject(Class:="MSProject.Application") 'late binding
    
    'Turn MS Project calculations and screen updating off to make code run faster.
    prjApp.Calculation = 0 'pjManual
    prjApp.ScreenUpdating = False
    
    For r = 2 To ActiveSheet.UsedRange.Rows.Count
        For Each res In prjApp.ActiveProject.Resources
            'Check if the resource in the project resource sheet is the same as the one in our spreadsheet.
            If Trim(ws.Cells(r, 1)) = Trim(res.Name) Then 
                'Call method to delete current rates with the same effective dates as we are going to add
                DeleteExistingRates res
                'Call method to add new rates
                AddNewRates res
                'Color the cell so we know the import occured
                ws.Cells(r, 1).Interior.Color = vbYellow
            End If
        Next res
    Next r
    
    'Turn MS Project calculations and screen updating back on
    prjApp.Calculation = -1 'pjAutomatic
    prjApp.ScreenUpdating = True

End Sub

Private Sub DeleteExistingRates(res As Object)

    If Not res Is Nothing Then
        Dim rRate As Object
        Dim pRate As Object
        Dim c As Integer
        
        Set rRate = res.CostRateTables(1)
        
        'Loop through all the payrate objects and remove the rates with the same effective dates as our new rates
        For Each pRate In rRate.PayRates
            For c = 2 To ws.UsedRange.Columns.Count
                If IsDate(ws.Cells(1, c)) Then
                    'check if effective dates are the same date
                    If Format(pRate.EffectiveDate, "mm/dd/yyyy") = Format(ws.Cells(1, c), "mm/dd/yyyy") Then
                        pRate.Delete
                    End If
                End If
            Next c
        Next pRate
    End If

End Sub

Private Sub AddNewRates(res As Object)
    
    If Not res Is Nothing Then
        Dim rRate As Object
        Dim pRate As Object
        Dim c As Integer
        
        Set rRate = res.CostRateTables(1)
        
        'Add all the new rates we want from our spreadsheet using this loop
        For c = 2 To ws.UsedRange.Columns.Count
            Set pRate = rRate.PayRates.Add(CDate(ws.Cells(1, c)), CDbl(ws.Cells(r, c))) 'parameters are the effective date and the rate
            
            'color rate cell so we know the rate was imported
            ws.Cells(r, c).Interior.Color = vbYellow
        Next c
    End If

End Sub

请注意，由于我在 Excel VBA 中编写代码，因此我使用 Late Binding（other helpful article) 来访问 MS Project 对象。