使用Excel VBA从多个MS项目文件中检索数据

Question

我遇到了一个似乎无法弄清楚的自动化问题。

目前，我有一个工作表("项目"(，其中包含"A"(项目名称(和"B"(项目文件位置(列中的数据。 列"B"包含每个 MS 项目文件的字符串位置。

我的 VBA 宏循环遍历"B"列并打开每个 MS 项目文件并复制带有 .选择任务字段方法，然后将其复制回工作表的列"E"。

前 2 个项目循环没有任何问题，但是，在第三个项目中，我收到运行时错误"1004"：该方法发生意外错误。 我和我的同事已经翻阅了代码和 MS 项目文件，看看数据中是否有任何差异，我们找不到任何差异。

下面是我一直在使用的代码的副本。 只是想看看是否有其他人遇到过类似的问题。我发现MS Project不喜欢像Excel或Word那样纵。

任何帮助将不胜感激。

Sub Test()
Dim ws As Worksheet
Set ws = Worksheets("Projects")
Dim lrow As Long
lrow = Range("B" & Rows.Count).End(xlUp).Row
'Turns off updates and alerts
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'Select Daily Field Reports and clear worksheet
ws.Range("E2:E" & lrow).ClearContents
'Opens MS Project
Set objproject = CreateObject("MSProject.Project")
'This keeps MS Project invisible. If you want to see it, change to "True"
objproject.Application.Visible = True
Dim oproject As Range
'This cycles through the range and gathers the data for each project
For Each oproject In Range("B2:B" & lrow)
Set objproject = CreateObject("MSProject.Project")
oproject.Select
objproject.Application.FileOpen Selection
objproject.Application.Visible = True
objproject.Application.SelectTaskField Row:=1, Column:="Percent Complete", RowRelative:=False  'The column name must match. This is the only issue that I have uncovered.
objproject.Application.EditCopy
ws.Select
Dim lastrow As Long
lastrow = ws.Cells(Rows.Count, "E").End(xlUp).Row + 1
Dim Rng As Range
Set Rng = ws.Range("E" & lastrow)
'Rng.PasteSpecial xlPasteFormats
Rng.PasteSpecial xlPasteValues
objproject.Application.Quit
Next oproject
'Turns updates and alerts back on
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'Closes MS Project
objproject.Application.Quit
End Sub

Answer 1

使用 SelectTaskField 方法假定文件已保存在任务视图中，并且所需的列位于视图的表中。最好直接从 Task 对象获取所需的值。

您似乎正在寻找第一个任务中的"完成百分比"值。在这种情况下，请使用以下命令：

objproject.ActiveProject.Tasks(1).PercentComplete

以下是它在代码中的工作方式。我冒昧地简化了它：

Sub Test()
Dim ws As Worksheet
Set ws = Worksheets("Projects")
Dim lrow As Long
lrow = Range("B" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = True
Application.DisplayAlerts = True
ws.Range("E2:E" & lrow).ClearContents
Dim objproject As MSProject.Application
Set objproject = CreateObject("MSProject.Application")
objproject.Application.Visible = True
Dim oproject As Range
For Each oproject In Range("B2:B" & lrow)
objproject.FileOpen Name:=oproject.Value, ReadOnly:=True
oproject.Offset(, 3) = objproject.ActiveProject.Tasks(1).PercentComplete
objproject.FileCloseEx
Next oproject
Application.ScreenUpdating = True
Application.DisplayAlerts = True
objproject.Quit
End Sub

请注意，获取对应用程序对象的引用比获取该对象的子对象更直接：CreateObject("MSProject.Application")比CreateObject("MSProject.Project")更可取。