'~~> 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。但我不知道该怎么做。我的MPP有很多任务。 请帮助。
我已经提到了以下链接,但是我无法获得如何将任务数据从MPP复制到excel的代码 enter link description here
答案 0 :(得分:1)
以下是一些可以激励您的代码(Project 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