如何將任務數據從Microsoft Project Plan複製到Excel？

Question

'~~> Code to open MPP file in Excel 

Sub Sample() 

Dim appProj As MSProject.Application 
Dim aProg As MSProject.Project 
Dim wb As Workbook 
Dim ws As Worksheet 

Set wb = ActiveWorkbook 

'~~> This is the Sheet Where you want the data to be copied 
Set ws = wb.Sheets("Sheet1") 

Set appProj = CreateObject("Msproject.Application") 

'~~> This is a MS Project File. Change path as applicable. 
appProj.FileOpen "C:\MS Project.mpp" 

Set aProg = appProj.ActiveProject 

appProj.Visible = True 

'~~> Now you have the MPP file opened, rest of the code goes here 
End Sub 

我已經成功打開MPP文件，但我想複製特定的任務數據到Excel.But我不知道該怎麼做。我的MPP有很多任務。 請幫助。

我已經提到了下面的鏈接，但我不能讓代碼如何從MPP複製任務的數據到Excel enter link description here

Answer 1

下面是一些代碼（項目VBA），可以激發你：

'This module contains macros which will export 
'tasks to excel and keep the task hierarchy. 
'modify as necessary to include other task information 

'Copyright Jack Dahlgren, Feb 2002 

Option Explicit 
Dim xlRow As Excel.Range 
Dim xlCol As Excel.Range 
Sub TaskHierarchy() 
Dim xlApp As Excel.Application 
Dim xlBook As Excel.Workbook 
Dim xlSheet As Excel.Worksheet 
Dim Proj As Project 
Dim t As Task 
Dim Asgn As Assignment 
Dim ColumnCount as Integer 
Dim Columns as Integer 
Dim Tcount As Integer 

Set xlApp = New Excel.Application 
xlApp.Visible = True 
AppActivate "Microsoft Excel" 

Set xlBook = xlApp.Workbooks.Add 
Set xlSheet = xlBook.Worksheets.Add 
xlSheet.Name = ActiveProject.Name 

'count columns needed 
ColumnCount = 0 
For Each t In ActiveProject.Tasks 
    If Not t Is Nothing Then 
     If t.OutlineLevel > ColumnCount Then 
      ColumnCount = t.OutlineLevel 
     End If 
    End If 
Next t 

'Set Range to write to first cell 
Set xlRow = xlApp.ActiveCell 
xlRow = "Filename: " & ActiveProject.Name 
dwn 1 
xlRow = "OutlineLevel" 
dwn 1 

'label Columns 
For Columns = 1 To (ColumnCount + 1) 
    Set xlCol = xlRow.Offset(0, Columns - 1) 
    xlCol = Columns - 1 
Next Columns 
rgt 2 
xlCol = "Resource Name" 
rgt 1 
xlCol = "work" 
rgt 1 
xlCol = "actual work" 
Tcount = 0 
For Each t In ActiveProject.Tasks 
    If Not t Is Nothing Then 
     dwn 1 
     Set xlCol = xlRow.Offset(0, t.OutlineLevel) 
     xlCol = t.Name 
      If t.Summary Then 
       xlCol.Font.Bold = True 
      End If 
     For Each Asgn In t.Assignments 
      dwn 1 
      Set xlCol = xlRow.Offset(0, Columns) 
      xlCol = Asgn.ResourceName 
      rgt 1 
      xlCol = (Asgn.Work/480) & " Days" 
      rgt 1 
      xlCol = (Asgn.ActualWork/480) & " Days" 
     Next Asgn 
     Tcount = Tcount + 1 
    End If 
Next t 
AppActivate "Microsoft Project" 

MsgBox ("Macro Complete with " & Tcount & " Tasks Written") 
End Sub 
Sub dwn(i As Integer) 
Set xlRow = xlRow.Offset(i, 0) 
End Sub 

Sub rgt(i As Integer) 
Set xlCol = xlCol.Offset(0, i) 
End Sub 

Source