用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

- ERKSMTY

---

为什么不把“ActiveSheet”也分配给一个变量呢？这将有助于减少任何模糊性，因为它是活动工作表。 - BruceWayne

请看下面我的答案和代码。 - Shai Rado

@ShaiRado 非常感谢。帮了大忙！ - ERKSMTY

Answer 1

我不确定你上面的原始代码是如何工作的，因为您声明并设置了变量appProj，但后来尝试使用projApp.Application.FileOpenEx "C:File.mpp"（projApp <> appProj）打开MS-Project文件。

请尝试下面的代码（已测试通过），它将会把3列 ("Name" , "Resource Names" 和 "Finish") 复制到"Project Data"工作表的"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

- Shai Rado

---

我在修改代码时遇到了一些问题，需要循环读取工作表中存储的路径（而不是在代码中定义路径）。有什么建议吗？[链接]（http://stackoverflow.com/questions/44012400/misunderstood-runtime-error-vba-for-excel-and-ms-project） - ERKSMTY

@ERKSMTY，您应该发布一个新问题，准确描述您想要实现的内容，并添加相关代码。这将使其他用户和我能够帮助您。 - Shai Rado

请查看我上一条评论中的链接。 - ERKSMTY