如何通过宏从Excel表格导入多财年资源费率至Microsoft Project并定期更新费率表A

我手里有一份Excel表格，记录了未来10个财年（每个财年从每年5月1日开始）各类资源的费率，而且这些费率每个月都可能变动（比如员工晋升就会调整）。现在我需要把这些费率导入到Microsoft Project的资源工作表（Resource Sheet）里，并且更新资源费率表A（CostRateTables(1)），让它准确反映每个财年的最新费率。

我知道得用宏来实现，但一开始没头绪——导入映射完全满足不了我的需求。我自己试着写了一段初始代码，但它是基于Project里已有的自定义字段来取费率的，得先建10个自定义字段才行，可我的数据都存在Excel里啊。而且每个资源在Excel和Project里都有唯一的resCode可以用来匹配。

我想要实现的是直接从Excel读取费率数据，每月运行宏就能更新Project里的资源费率。之前看到过一段相关代码，但它没涉及从Excel读数据的逻辑。

具体需求总结 #

• 数据源：Excel表格，包含未来10个财年的资源费率，财年起始日为每年5月1日，支持月度费率变动
• 匹配依据：资源唯一编码resCode，实现Excel与Project资源的精准匹配
• 目标：每月运行宏，自动读取Excel数据并更新Project的资源费率表A（CostRateTables(1)）

最优实现方案代码 #

下面是完整的VBA宏代码，实现从指定Excel文件读取数据并更新Project资源费率：

Sub UpdateResourceRatesFromExcel()
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlWS As Object
    Dim projRes As Resource
    Dim xlRow As Integer
    Dim lastXlRow As Integer
    Dim resCodeMatch As String
    Dim rateStartDate As Date
    Dim standardRate As String
    
    ' 请修改为你的Excel文件路径
    Const EXCEL_FILE_PATH As String = "C:\YourPath\ResourceRates.xlsx"
    ' 请修改为存储费率的工作表名称
    Const EXCEL_SHEET_NAME As String = "RateData"
    
    ' 初始化Excel应用
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = False ' 后台运行Excel，不显示界面
    
    ' 打开Excel工作簿
    On Error Resume Next
    Set xlWB = xlApp.Workbooks.Open(EXCEL_FILE_PATH)
    If Err.Number <> 0 Then
        MsgBox "无法打开指定的Excel文件，请检查路径是否正确！", vbCritical
        xlApp.Quit
        Set xlApp = Nothing
        Exit Sub
    End If
    On Error GoTo 0
    
    ' 定位到目标工作表
    Set xlWS = xlWB.Worksheets(EXCEL_SHEET_NAME)
    lastXlRow = xlWS.Cells(xlWS.Rows.Count, "A").End(-4162).Row ' -4162对应xlUp
    
    ' 遍历Excel中的费率数据
    For xlRow = 2 To lastXlRow ' 假设第一行是表头
        resCodeMatch = xlWS.Cells(xlRow, "A").Value ' 假设A列是resCode
        rateStartDate = xlWS.Cells(xlRow, "B").Value ' 假设B列是费率生效日期
        standardRate = xlWS.Cells(xlRow, "C").Value ' 假设C列是标准费率
        
        ' 在Project中匹配对应的资源
        For Each projRes In ActiveProject.Resources
            If Not projRes Is Nothing And projRes.GetField(FieldNameToFieldConstant("resCode", pjResource)) = resCodeMatch Then
                ' 更新费率表A的对应时段费率
                With projRes.CostRateTables(1).PayRates
                    ' 检查是否已存在该生效日期的费率，若存在则更新，否则添加新费率
                    Dim existingRate As PayRate
                    Dim rateExists As Boolean
                    rateExists = False
                    For Each existingRate In .PayRates
                        If existingRate.EffectiveDate = rateStartDate Then
                            existingRate.StandardRate = standardRate
                            rateExists = True
                            Exit For
                        End If
                    Next existingRate
                    
                    If Not rateExists Then
                        .Add EffectiveDate:=rateStartDate, StandardRate:=standardRate
                    End If
                End With
                Exit For ' 找到匹配资源后退出循环
            End If
        Next projRes
    Next xlRow
    
    ' 清理资源
    xlWB.Close SaveChanges:=False
    xlApp.Quit
    Set xlWS = Nothing
    Set xlWB = Nothing
    Set xlApp = Nothing
    
    MsgBox "资源费率更新完成！", vbInformation
End Sub

代码使用说明 #

1. Excel表格格式要求：
   • 表头建议包含：resCode（A列）、生效日期（B列，格式为日期，比如2024/5/1）、标准费率（C列，格式为Project支持的费率格式，比如"¥150/h"或"$200/d"）
   • 可以根据实际列位置修改代码中对应列的引用（比如把"A"改成"D"如果resCode在D列）
2. Project设置：
   • 确保Project中的资源已经添加了resCode自定义字段（资源自定义字段，类型为文本），用来和Excel中的编码匹配
3. 运行宏：
   • 打开目标Project文件，按Alt+F11打开VBA编辑器
   • 插入模块，粘贴上述代码
   • 修改代码开头的EXCEL_FILE_PATH和EXCEL_SHEET_NAME为你的实际路径和工作表名
   • 运行宏即可完成更新

注意事项 #

• 运行宏前建议备份Project文件和Excel文件，避免数据错误
• 如果Excel文件正在打开，需要先关闭再运行宏，否则会报错
• 费率格式要符合Project的要求，比如小时费率用/h，天费率用/d，否则Project无法识别

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