excel - Microsoft Project - 从 Excel 电子表格导入资源费率
问题描述
我收到了一份电子表格,其中列出了未来十年每个财政年度的一些资源和资源费率。每年的 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 - 多年通货膨胀
总之:
未来 10 年每年的资源费率存储在电子表格中。
资源在 Excel 工作表和项目中都唯一地映射到资源代码 (resCode)。
每月需要通过运行宏导入费率来更新费率。
任何有关如何最好地实现这一目标的帮助将不胜感激。
解决方案
我相信您希望能够从这样的电子表格中导入费率:
在此示例中,资源名称列在 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 中编写代码,因此我使用后期绑定(其他有用的文章)来访问 MS Project 对象。
推荐阅读
- android - Kotlin 过滤方法
- excel - 多次重新打印行并进行修改
- python - 无 类型不可迭代(RecurrentTabularExplainer)
- javascript - @蚂蚁设计。为什么所有图标都添加到捆绑包中?
- python-3.x - Tkinter 忽略画布
- asp.net-core - Blazor 服务器端 AllowAnonymousToFolder
- git - 如何在嵌套文件夹中添加另一个自述文件并将图像添加到 github 存储库中的自述文件中?
- python - Python Socket在同一个覆盆子上发送和接收不起作用
- c# - 如何从另一个日期时间中减去一个日期时间并保存到日期和时间?
- react-native - onError 导入未在 Apollo 中使用