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

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

出于某种原因，它会将五行代码复制到所需的工作表中，而不是指定的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和SetvariablesappProj ，但后来试图打开MS-Project文件projApp.Application.FileOpenEx "C:File.mpp" （ projApp <> appProj ）。

尝试下面的代码（testing），它会将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