VBA 将数据从 Project 复制粘贴到 Excel

Question

我正在运行下面的代码并得到虚假的结果。

出于某种原因，它将五行代码复制到所需的工作表中，而不是指定的 MS Project 数据中。

任何人都可以帮助新手吗？

五行代码错误地复制到 Excel 工作表中：

'Open MS Project file
projApp.Application.FileOpenEx "C:File.mpp"

Set projApp = projApp.ActiveProject

'Final set up of code
Set projApp = Nothing

Sub OpenProjectCopyPasteData()

Dim appProj As MSProject.Application
Dim aProg As MSProject.Project
Dim sel As MSProject.Selection
Dim ts As Tasks
Dim t As Task
Dim rng As Range
Dim ws As Worksheet

Application.DisplayAlerts = False

'Clear current contents

Set ws = Worksheets("Project Data")
Set rng = ws.Range("A:J")
rng.ClearContents

On Error Resume Next
Set appProj = GetObject(, "MSProject.Application")
If appProj Is Nothing Then
    Set appProj = New MSProject.Application
End If
appProj.Visible = True

'Open MS Project file
projApp.Application.FileOpenEx "C:File.mpp"
Set projApp = projApp.ActiveProject

'Final set up of code
Set projApp = Nothing

appProj.Visible = True

WindowActivate WindowName:=aProg

'Copy the project columns and paste into Excel
Set ts = aProg.Tasks

SelectTaskColumn Column:="Task Name"
OutlineShowAllTasks
OutlineShowAllTasks
EditCopy
Set ws = Worksheets("Project Data")
Set rng = ws.Range("A:A")
ActiveSheet.Paste Destination:=rng

SelectTaskColumn Column:="Task Name"
EditCopy
Set rng = ws.Range("B:B")
ActiveSheet.Paste Destination:=rng

SelectTaskColumn Column:="Resource Names"
EditCopy
Set rng = ws.Range("C:C")
ActiveSheet.Paste Destination:=rng

SelectTaskColumn Column:="Finish"
EditCopy
Set rng = ws.Range("D:D")
ActiveSheet.Paste Destination:=rng

Application.DisplayAlerts = True
appProj.DisplayAlerts = True

End Sub

Answer 1

我不确定你上面的原始代码是如何工作的，因为你Dim并Set了变量appProj ，但后来试图用projApp.Application.FileOpenEx "C:File.mpp" ( projApp <> appProj ) 打开 MS-Project 文件。

试试下面的代码（经过测试），它会将 3 列（ "Name" 、 "Resource Names"和"Finish" ）复制到“A:C”列的工作表“项目数据”。

代码

Option Explicit

Sub OpenProjectCopyPasteData()

Dim PrjApp      As MSProject.Application
Dim aProg       As MSProject.Project
Dim PrjFullName As String
Dim t           As Task
Dim rng         As Range
Dim ws          As Worksheet

Application.ScreenUpdating = False
Application.DisplayAlerts = False

'Clear current contents
Set ws = Worksheets("Project Data")
Set rng = ws.Range("A:J")
rng.ClearContents

On Error Resume Next
Set PrjApp = GetObject(, "MSProject.Application")
If PrjApp Is Nothing Then
    Set PrjApp = New MSProject.Application
End If
On Error GoTo 0
PrjApp.ScreenUpdating = False
PrjApp.Visible = True

'Open MS Project file
PrjFullName = "C:File.mpp" '<-- keep the MS-Project file name and path in a variable
PrjApp.Application.FileOpenEx PrjFullName
Set aProg = PrjApp.ActiveProject

' show all tasks
OutlineShowAllTasks

'Copy the project columns and paste into Excel
SelectTaskColumn Column:="Name"
EditCopy
Set ws = Worksheets("Project Data")
Set rng = ws.Range("A:A")
rng.PasteSpecial xlPasteValues
rng.PasteSpecial xlPasteFormats

SelectTaskColumn Column:="Resource Names"
EditCopy
Set rng = ws.Range("B:B")
rng.PasteSpecial xlPasteValues
rng.PasteSpecial xlPasteFormats

SelectTaskColumn Column:="Finish"
EditCopy
Set rng = ws.Range("C:C")
rng.PasteSpecial xlPasteValues
rng.PasteSpecial xlPasteFormats

' reset settings of Excel and MS-Project
Application.DisplayAlerts = True
Application.ScreenUpdating = True
PrjApp.ScreenUpdating = True
PrjApp.DisplayAlerts = True

'PrjApp.FileClose False
PrjApp.Quit pjDoNotSave
Set PrjApp = Nothing

End Sub