Excel VBA从MS Project导入数据提速方法咨询

问题描述 #

我正在编写Excel VBA程序，用于打开MS Project文件，通过遍历任务的循环将指定列的信息复制到Excel中。但由于逐个任务循环处理，当项目包含大量活动时处理速度极慢。当前遍历任务并复制信息的循环代码如下：

i = 2 
For Each Tarea In Proj.Tasks
    Ws.Cells(i, 1).Value = Tarea.WBS 
    Ws.Cells(i, 2).Value = Tarea.OutlineLevel 
    Ws.Cells(i, 3).Value = Tarea.Summary 'Resumen
    Ws.Cells(i, 4).Value = Tarea.Name 'Nombre de tarea
    Ws.Cells(i, 5).Value = Tarea.Duration
    Ws.Cells(i, 6).Value = Tarea.Start
    Ws.Cells(i, 7).Value = Tarea.Finish
    Ws.Cells(i, 8).Value = Tarea.Predecessors
    Ws.Cells(i, 9).Value = Tarea.Successors
    Ws.Cells(i, 10).Value = Tarea.Milestone
    Ws.Cells(i, 11).Value = Tarea.Critical
    Ws.Cells(i, 12).Value = Tarea.ResourceNames
    Ws.Cells(i, 13).Value = Tarea.Work
    i = i + 1
Next Tarea

代码可正常运行，但项目活动较多时速度过慢。请问能否在Excel VBA中执行MS Project范围复制后粘贴到Excel的命令，以此提升信息提取速度？

解决方案 #

方法一：利用MS Project范围复制粘贴 #

直接在MS Project中配置目标字段视图，批量复制任务数据后粘贴到Excel，这种方式避免了逐个单元格读写，速度提升显著。

示例代码：

Sub CopyProjectTasksToExcel()
    Dim projApp As MSProject.Application
    Dim proj As MSProject.Project
    Dim ws As Worksheet
    Dim targetRange As Range
    
    ' 初始化对象
    Set projApp = New MSProject.Application
    Set proj = projApp.Open("C:\YourProjectFile.mpp") ' 替换为你的MS Project文件路径
    Set ws = ThisWorkbook.Worksheets("Sheet1") ' 替换为目标工作表
    Set targetRange = ws.Range("A2")
    
    ' 创建自定义任务表格，添加需要的字段
    projApp.ViewApply Name:="Gantt Chart"
    projApp.TableEditEx Name:="Entry", TaskTable:=True, _
        NewName:="TempTaskTable", OverwriteExisting:=True, _
        FieldName:="WBS", Title:="WBS", Width:=10, Align:=pjAlignLeft
    projApp.TableEditEx Name:="TempTaskTable", TaskTable:=True, _
        FieldName:="Outline Level", Title:="OutlineLevel", Width:=10, Align:=pjAlignLeft
    projApp.TableEditEx Name:="TempTaskTable", TaskTable:=True, _
        FieldName:="Summary", Title:="Summary", Width:=10, Align:=pjAlignCenter
    projApp.TableEditEx Name:="TempTaskTable", TaskTable:=True, _
        FieldName:="Name", Title:="TaskName", Width:=30, Align:=pjAlignLeft
    projApp.TableEditEx Name:="TempTaskTable", TaskTable:=True, _
        FieldName:="Duration", Title:="Duration", Width:=10, Align:=pjAlignRight
    projApp.TableEditEx Name:="TempTaskTable", TaskTable:=True, _
        FieldName:="Start", Title:="Start", Width:=15, Align:=pjAlignCenter
    projApp.TableEditEx Name:="TempTaskTable", TaskTable:=True, _
        FieldName:="Finish", Title:="Finish", Width:=15, Align:=pjAlignCenter
    projApp.TableEditEx Name:="TempTaskTable", TaskTable:=True, _
        FieldName:="Predecessors", Title:="Predecessors", Width:=15, Align:=pjAlignLeft
    projApp.TableEditEx Name:="TempTaskTable", TaskTable:=True, _
        FieldName:="Successors", Title:="Successors", Width:=15, Align:=pjAlignLeft
    projApp.TableEditEx Name:="TempTaskTable", TaskTable:=True, _
        FieldName:="Milestone", Title:="Milestone", Width:=10, Align:=pjAlignCenter
    projApp.TableEditEx Name:="TempTaskTable", TaskTable:=True, _
        FieldName:="Critical", Title:="Critical", Width:=10, Align:=pjAlignCenter
    projApp.TableEditEx Name:="TempTaskTable", TaskTable:=True, _
        FieldName:="Resource Names", Title:="ResourceNames", Width:=20, Align:=pjAlignLeft
    projApp.TableEditEx Name:="TempTaskTable", TaskTable:=True, _
        FieldName:="Work", Title:="Work", Width:=10, Align:=pjAlignRight
    
    ' 批量复制粘贴
    projApp.SelectAll
    projApp.EditCopy
    targetRange.PasteSpecial Paste:=xlPasteValues
    
    ' 清理临时表格
    projApp.TableDelete Name:="TempTaskTable", TaskTable:=True
    proj.Close SaveChanges:=False
    projApp.Quit
    
    ' 释放对象
    Set proj = Nothing
    Set projApp = Nothing
End Sub

方法二：数组批量读写 #

如果不想依赖MS Project视图配置，可以先将任务数据读取到VBA数组，再一次性写入Excel，同样能大幅减少单元格交互次数。

示例代码：

Sub ReadTasksWithArray()
    Dim projApp As MSProject.Application
    Dim proj As MSProject.Project
    Dim ws As Worksheet
    Dim taskArr As Variant
    Dim t As MSProject.Task
    Dim i As Long, rowCount As Long
    
    ' 初始化对象
    Set projApp = New MSProject.Application
    Set proj = projApp.Open("C:\YourProjectFile.mpp")
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    ' 统计有效任务数量（排除空任务）
    rowCount = 0
    For Each t In proj.Tasks
        If Not t Is Nothing Then rowCount = rowCount + 1
    Next t
    
    ' 初始化数组
    ReDim taskArr(1 To rowCount, 1 To 13)
    
    ' 批量读取任务数据到数组
    i = 1
    For Each t In proj.Tasks
        If Not t Is Nothing Then
            taskArr(i, 1) = t.WBS
            taskArr(i, 2) = t.OutlineLevel
            taskArr(i, 3) = t.Summary
            taskArr(i, 4) = t.Name
            taskArr(i, 5) = t.Duration
            taskArr(i, 6) = t.Start
            taskArr(i, 7) = t.Finish
            taskArr(i, 8) = t.Predecessors
            taskArr(i, 9) = t.Successors
            taskArr(i, 10) = t.Milestone
            taskArr(i, 11) = t.Critical
            taskArr(i, 12) = t.ResourceNames
            taskArr(i, 13) = t.Work
            i = i + 1
        End If
    Next t
    
    ' 一次性写入Excel
    ws.Range("A2").Resize(rowCount, 13).Value = taskArr
    
    ' 清理资源
    proj.Close SaveChanges:=False
    projApp.Quit
    Set proj = Nothing
    Set projApp = Nothing
End Sub

注意事项 #

• 运行代码前需在VBA编辑器的工具→引用中勾选Microsoft Project xx.x Object Library。
• 方法一中的临时表格名称可自行修改，避免与现有表格冲突。
• 方法二中需排除Nothing类型的任务，因为MS Project的Tasks集合可能包含未初始化的空任务。

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