Option Explicit
Dim xlRow As Excel.Range
Dim xlCol As Excel.Range
Dim NbrTask As Integer
Sub ExtractMSP()
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
Dim TRowCount As Integer
Dim ActP As String
Dim KT As String
'=========== Destination Path Name =================
Dim dPath As String
dPath = "D:\ \" ' set the pathname here
Dim wb As Workbook
Dim NewShtName As String
Dim OrgFileName As String
Dim Counter As Integer: Counter = 1
Dim PctDone As Single
'
Entry_View
'
Set xlApp = New Excel.Application
xlApp.Visible = True
AppActivate "Microsoft Excel"
OrgFileName = dPath & "ScheduleTemplate.xlsm"
Workbooks.Open FileName:=OrgFileName
Sheets("Sheet2").Select
Cells.Select
Selection.Copy
Sheets("Task_Table1").Select
Cells.Select
ActiveSheet.Paste
Range("A1").Select
ColumnCount = 0
TRowCount = 1
For Each T In ActiveProject.Tasks
Application.ScreenUpdating = False
If Not T Is Nothing Then
If T.OutlineLevel > ColumnCount Then
ColumnCount = T.OutlineLevel
End If
End If
Next T
ColumnCount = ColumnCount - 1
'Set Range to write to first cell
Set xlRow = xlApp.ActiveCell
xlRow = "Filename: " & Left(ActiveProject.Name, Len(ActiveProject.Name))
TRowCount = TRowCount + 1
dwn 1
xlRow = "OutlineLevel"
TRowCount = TRowCount + 1
dwn 1
'label Columns
For Columns = 1 To (ColumnCount + 1)
Set xlCol = xlRow.Offset(0, Columns - 1)
xlCol = Columns - 1
Next Columns
'
' rgt is the column skip to the right
'
rgt 2
xlCol = "WBS"
rgt 1
xlCol = "Task ID"
rgt 1
xlCol = "% Complete"
rgt 1
xlCol = "Duration"
rgt 1
xlCol = "Start"
rgt 1
xlCol = "Finish"
rgt 1
xlCol = "Actual Start"
rgt 1
xlCol = "Actual Finish"
rgt 1
xlCol = "Predecessor"
rgt 1
xlCol = "Successor"
rgt 1
xlCol = "Critical"
rgt 1
xlCol = "Milestone"
rgt 1
xlCol = "Resource Name"
rgt 1
xlCol = "Resource Group"
Tcount = 0
For Each T In ActiveProject.Tasks
If Not T Is Nothing Then
Tcount = Tcount + 1
TRowCount = TRowCount + 1
dwn 1
Set xlCol = xlRow.Offset(0, T.OutlineLevel)
xlCol = T.Name
If T.Summary Then
xlCol.Font.Bold = True
'
' Added to print the data that belongs to the Summary Tasks
'
Set xlCol = xlRow.Offset(0, Columns)
xlCol = T.WBS
xlCol.Font.Bold = True
rgt 1
xlCol = T.ID
xlCol.Font.Bold = True
rgt 1
xlCol = (T.PercentComplete / 100)
xlCol.Font.Bold = True
rgt 1
xlCol = Int(T.Duration / 480) & " d"
xlCol.Font.Bold = True
rgt 1
xlCol = T.Start
xlCol.Font.Bold = True
rgt 1
xlCol = T.Finish
xlCol.Font.Bold = True
rgt 1
xlCol = T.ActualStart
xlCol.Font.Bold = True
rgt 1
xlCol = T.ActualFinish
xlCol.Font.Bold = True
rgt 1
xlCol = T.Predecessors
xlCol.Font.Bold = True
rgt 1
xlCol = T.Successors
xlCol.Font.Bold = True
rgt 1
If T.Critical = True Then
xlCol = "Yes"
xlCol.Font.Bold = True
Else
xlCol = "No"
xlCol.Font.Bold = True
End If
rgt 1
If T.Milestone = True Then
xlCol = "Yes"
xlCol.Font.Bold = True
Else
xlCol = "No"
xlCol.Font.Bold = True
End If
rgt 1
xlCol = T.ResourceNames
xlCol.Font.Bold = True
rgt 1
xlCol = T.ResourceGroup
xlCol.Font.Bold = True
rgt 1
End If
For Each Asgn In T.Assignments
Set xlCol = xlRow.Offset(0, Columns)
xlCol = T.WBS
xlCol.Font.Bold = False
rgt 1
xlCol = T.ID
xlCol.Font.Bold = False
rgt 1
xlCol = (T.PercentComplete / 100)
xlCol.Font.Bold = False
rgt 1
xlCol = Int(T.Duration / 480) & " d"
xlCol.Font.Bold = False
rgt 1
xlCol = T.Start
xlCol.Font.Bold = False
rgt 1
xlCol = T.Finish
xlCol.Font.Bold = False
rgt 1
xlCol = T.ActualStart
xlCol.Font.Bold = True
rgt 1
xlCol = T.ActualFinish
xlCol.Font.Bold = True
rgt 1
xlCol = T.Predecessors
xlCol.Font.Bold = True
rgt 1
xlCol = T.Successors
xlCol.Font.Bold = True
rgt 1
If T.Critical = True Then
xlCol = "Yes"
xlCol.Font.Bold = True
Else
xlCol = "No"
xlCol.Font.Bold = True
End If
rgt 1
If T.Milestone = True Then
xlCol = "Yes"
xlCol.Font.Bold = False
Else
xlCol = "No"
xlCol.Font.Bold = False
End If
rgt 1
xlCol = T.ResourceNames
xlCol.Font.Bold = False
rgt 1
xlCol = T.ResourceGroup
xlCol.Font.Bold = False
rgt 1
Next Asgn
'
' Added to print the data that belongs to the Tasks that have no Assignments
'
If T.Summary Then
Set xlCol = xlRow.Offset(0, Columns)
xlCol = T.WBS
xlCol.Font.Bold = True
rgt 1
xlCol = T.ID
xlCol.Font.Bold = True
rgt 1
xlCol = (T.PercentComplete / 100)
xlCol.Font.Bold = True
rgt 1
xlCol = Int(T.Duration / 480) & " d"
xlCol.Font.Bold = True
rgt 1
xlCol = T.Start
xlCol.Font.Bold = True
rgt 1
xlCol = T.Finish
xlCol.Font.Bold = True
rgt 1
xlCol = T.ActualStart
xlCol.Font.Bold = True
rgt 1
xlCol = T.ActualFinish
xlCol.Font.Bold = True
rgt 1
xlCol = T.Predecessors
xlCol.Font.Bold = True
rgt 1
xlCol = T.Successors
xlCol.Font.Bold = True
rgt 1
If T.Critical = True Then
xlCol = "Yes"
xlCol.Font.Bold = True
Else
xlCol = "No"
xlCol.Font.Bold = True
End If
rgt 1
If T.Milestone = True Then
xlCol = "Yes"
xlCol.Font.Bold = True
Else
xlCol = "No"
xlCol.Font.Bold = True
End If
rgt 1
xlCol = T.ResourceNames
xlCol.Font.Bold = True
rgt 1
xlCol = T.ResourceGroup
xlCol.Font.Bold = True
rgt 1
Else
Set xlCol = xlRow.Offset(0, Columns)
xlCol = T.WBS
xlCol.Font.Bold = False
rgt 1
xlCol = T.ID
xlCol.Font.Bold = False
rgt 1
xlCol = (T.PercentComplete / 100)
xlCol.Font.Bold = False
rgt 1
xlCol = Int(T.Duration / 480) & " d"
xlCol.Font.Bold = False
rgt 1
xlCol = T.Start
xlCol.Font.Bold = False
rgt 1
xlCol = T.Finish
xlCol.Font.Bold = False
rgt 1
xlCol = T.ActualStart
xlCol.Font.Bold = True
rgt 1
xlCol = T.ActualFinish
xlCol.Font.Bold = True
rgt 1
xlCol = T.Predecessors
xlCol.Font.Bold = True
rgt 1
xlCol = T.Successors
xlCol.Font.Bold = True
rgt 1
If T.Critical = True Then
xlCol = "Yes"
xlCol.Font.Bold = True
Else
xlCol = "No"
xlCol.Font.Bold = True
End If
rgt 1
If T.Milestone = True Then
xlCol = "Yes"
xlCol.Font.Bold = False
Else
xlCol = "No"
xlCol.Font.Bold = False
End If
rgt 1
xlCol = T.ResourceNames
xlCol.Font.Bold = False
rgt 1
xlCol = T.ResourceGroup
xlCol.Font.Bold = False
rgt 1
End If
End If
Next T
Application.ScreenUpdating = True
AppActivate "Microsoft Project"
MsgBox ("Macro Complete with " & Tcount & " Tasks Written")
AppActivate "Microsoft Project"
Application.Quit
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