VBA从项目复制粘贴数据到Excel [英] VBA Copy Paste Data into Excel from Project

问题描述

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

I'm running the code below and getting spurious results.

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

For some reason it copies five lines of code into the desired worksheet instead of the specified MS Project data.

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

Can Anyone help out a newbie?

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

Five lines of code incorrectly copied into Excel worksheet:

'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

推荐答案

由于您 Dim 和 Set 变量 appProj ，但稍后尝试使用 projApp.Application.FileOpenEx"C:File.mpp" ( projApp <> appProj ).

I am not sure how your original code above worked, since you Dim and Set the variable appProj, but later trying to open the MS-Project file with projApp.Application.FileOpenEx "C:File.mpp" (projApp <> appProj).

尝试下面的代码(已测试)，它将复制3列(名称" ，资源名称" 和完成" )到工作表项目数据"的"A:C"列.

Try the code below (tested), it will copy the 3 columns ("Name" , "Resource Names" and "Finish") to worksheet "Project Data" at columns "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

这篇关于VBA从项目复制粘贴数据到Excel的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！