VBA 将项目中的粘贴数据复制到 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，但后来试图用 [= 打开 MS-Project 文件14=] (projApp <> appProj).

尝试下面的代码（已测试），它会将 3 列（"Name"、"Resource Names" 和 "Finish"）复制到工作表 "Project Data" 的第 [=29] 列=].

代码

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

VBA 将项目中的粘贴数据复制到 Excel

VBA Copy Paste Data into Excel from Project

excel

vba

ms-project