Hey everyone,
I am trying to extract information from project to excel and do this via code. This is something that has to be continuously done as the project rolls on so doing it manually will take too much time. I have posted the code below that I have managed to piece together via perusing the internet, however when I run the code I get the error: " user defined type not defined". Any help is much appreciated, thank you so much in advance
Dim appXL As Excel.Application
Sub StonePlanStatusReport()
Dim t As Task
Dim s As Task
Dim tCurrentFinish As Date
Dim tLastFinish As Date
Dim tCurrentStart As Date
Dim tLastStart As Date
Dim MyWorkbook As Excel.Workbook
Dim mysheetF As Excel.Worksheet
Dim mysheetS As Excel.Worksheet
Dim mysheetC As Excel.Worksheet
Dim SheetrowF As Integer
Dim SheetrowS As Integer
Dim SheetrowC As Integer
Dim mytype As Integer
Dim lastbase As Integer
Dim olderbase As Integer
Dim NewReportCycle As Boolean
'Create the Excel Application
On Error Resume Next
Set appXL = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set appXL = CreateObject("Excel.<wbr>application")
End If
appXL.Visible = True
Set MyWorkbook = appXL.Workbooks.Add
'find which baseline is later
lastbase = 1
olderbase = 2
If ActiveProject.<wbr>BaselineSavedDate(pjBaseline2) > ActiveProject.<wbr>BaselineSavedDate(pjBaseline1) Then
lastbase = 2
olderbase = 1
End If
mytype = 1 'delayed finish sheet
Set mysheetF = MyWorkbook.Sheets(mytype)
mysheetF.Name = "Delayed Activities - Finish"
Call ExcelTopLine(mysheetF, mytype) 'headers
SheetrowF = 2
mytype = 2 'delayed start sheet
Set mysheetS = MyWorkbook.Sheets.Add
mysheetS.Name = "Delayed Activities - Start"
Call ExcelTopLine(mysheetS, mytype) 'headers
SheetrowS = 2
mytype = 3 'completed activities sheet
Set mysheetC = MyWorkbook.Sheets.Add
mysheetC.Name = "Completed Activities"
Call ExcelTopLine(mysheetC, mytype) 'headers
SheetrowC = 2
'initialise Flag20
For Each t In ActiveProject.Tasks
If Not t Is Nothing Then 'ignore blank lines
t.Flag20 = False
End If
Next t
'check if new report cycle
NewReportCycle = False
If ActiveProject.Tasks(1).Date10 <= ActiveProject.<wbr>BaselineSavedDate(olderbase) Then
NewReportCycle = True
ActiveProject.Tasks(1).Date10 = ActiveProject.<wbr>BaselineSavedDate(lastbase)
End If
'first work out which tasks should be in report
For Each t In ActiveProject.Tasks
If Not t Is Nothing Then 'ignore blank lines
If Not t.Summary Then 'only look at tasks
If t.Flag20 Then 'check if already excluded
For Each s In t.SuccessorTasks
s.Flag20 = True 'so exclude successors
Next s
Else 'if not already excluded, check if replanned
If lastbase = 1 Then
tCurrentStart = t.Baseline1Start
tLastStart = t.Baseline2Start
tCurrentFinish = t.Baseline1Finish
tLastFinish = t.Baseline2Finish
Else
tCurrentStart = t.Baseline2Start
tLastStart = t.Baseline1Start
tCurrentFinish = t.Baseline2Finish
tLastFinish = t.Baseline1Finish
End If
If tCurrentFinish > tLastFinish Or tCurrentStart > tLastStart Then 'replanned, so exclude successors
For Each s In t.SuccessorTasks
s.Flag20 = True 'exclude successors
Next s
End If
End If
End If
End If
Next t
'now do reports
For Each t In ActiveProject.Tasks
If Not t Is Nothing Then 'ignore blank lines
If Not t.Summary Then 'only look at tasks
If Not t.Flag19 Then 'task not previously complete
If t.PercentComplete = 100 Then 'write record to excel sheet
mysheetC.Cells(SheetrowC, 1) = t.ID 'ID
mysheetC.Cells(SheetrowC, 2) = Mid(t.Project, 7) 'project
mysheetC.Cells(SheetrowC, 3) = t.Name & " for " & t.OutlineParent.OutlineParent.<wbr>Name & " for " & t.OutlineParent.Name'description (with summary info)
mysheetC.Cells(SheetrowC, 4) = t.BaselineFinish 'baseline finish
If t.BaselineFinish = "NA" Then 'use Baseline3 if required
mysheetC.Cells(SheetrowC, 4) = t.Baseline3Finish
End If
mysheetC.Cells(SheetrowC, 5) = t.Finish 'finish
For Each s In t.SuccessorTasks
If mysheetC.Cells(SheetrowC, 6) = "" Then
<wbr> mysheetC.Cells(SheetrowC, 6) = s.Name 'successor task names to excel
Else 'append next successor
<wbr> mysheetC.Cells(SheetrowC, 6) = mysheetC.Cells(SheetrowC, 6) & "," & s.Name
End If
Next s
SheetrowC = SheetrowC + 1
If NewReportCycle Then t.Flag19 = True 'set flag for next cycle
End If
End If
If Not t.Flag20 Then 'look for tasks not flagged
'and check if delayed
If lastbase = 1 Then
tCurrentStart = t.Baseline1Start
tLastStart = t.Baseline2Start
tCurrentFinish = t.Baseline1Finish
tLastFinish = t.Baseline2Finish
Else
tCurrentStart = t.Baseline2Start
tLastStart = t.Baseline1Start
tCurrentFinish = t.Baseline2Finish
tLastFinish = t.Baseline1Finish
End If
'check start date first
If tCurrentStart > tLastStart Then 'start delayed, so populate excel sheet with data
mysheetS.Cells(SheetrowS, 1) = t.ID 'ID
mysheetS.Cells(SheetrowS, 2) = Mid(t.Project, 7) 'project
mysheetS.Cells(SheetrowS, 3) = t.Name & " for " & t.OutlineParent.OutlineParent.<wbr>Name & " for " & t.OutlineParent.Name'description (with summary info)
mysheetS.Cells(SheetrowS, 4) = t.BaselineStart 'baseline start
mysheetS.Cells(SheetrowS, 5) = t.Start 'start
mysheetS.Cells(SheetrowS, 6) = t.StartVariance / 480 & " d" 'slippage in days
If t.BaselineStart = "NA" Then 'use Baseline3 if required
t.BaselineStart = t.Baseline3Start
mysheetS.Cells(SheetrowS, 4) = t.BaselineStart 'baseline start
mysheetS.Cells(SheetrowS, 6) = t.StartVariance / 480 & " d" 'slippage in days
t.BaselineStart = "NA"
End If
mysheetS.Cells(SheetrowS, 7) = tLastStart 'previous week's start date
For Each s In t.SuccessorTasks
If mysheetS.Cells(SheetrowS, 8) = "" Then
<wbr> mysheetS.Cells(SheetrowS, 8) = s.Name 'successor task names to excel
Else 'append next successor
<wbr> mysheetS.Cells(SheetrowS, 8) = mysheetS.Cells(SheetrowS, 8) & "," & s.Name
End If
Next s
mysheetS.Cells(SheetrowS, 9) = t.Text19 'mitigation text
mysheetS.Cells(SheetrowS, 10) = t.TotalSlack / 480 & " d" 'float in days
mysheetS.Cells(SheetrowS, 11) = "R" 'status R or A
If t.TotalSlack > 0 Then mysheetS.Cells(SheetrowS, 11) = "A"
SheetrowS = SheetrowS + 1
Else 'start not delayed, so check finish date
If tCurrentFinish > tLastFinish Then 'finish delayed, so populate excel sheet with data
mysheetF.Cells(SheetrowF, 1) = t.ID 'ID
mysheetF.Cells(SheetrowF, 2) = Mid(t.Project, 7) 'project
mysheetF.Cells(SheetrowF, 3) = t.Name & " for " & t.OutlineParent.OutlineParent.<wbr>Name & " for " & t.OutlineParent.Name'description (with summary info)
mysheetF.Cells(SheetrowF, 4) = t.BaselineFinish 'baseline finish
mysheetF.Cells(SheetrowF, 5) = t.Finish 'finish
mysheetF.Cells(SheetrowF, 6) = t.FinishVariance / 480 & " d" 'slippage in days
If t.BaselineFinish = "NA" Then 'use Baseline3 if required
<wbr> t.BaselineFinish = t.Baseline3Finish
<wbr> mysheetF.Cells(SheetrowF, 4) = t.BaselineFinish 'baseline finish
<wbr> mysheetF.Cells(SheetrowF, 6) = t.FinishVariance / 480 & " d" 'slippage in days
<wbr> t.BaselineFinish = "NA"
End If
mysheetF.Cells(SheetrowF, 7) = tLastFinish 'previous week's finish date
For Each s In t.SuccessorTasks
<wbr> If mysheetF.Cells(SheetrowF, 8) = "" Then
<wbr> mysheetF.Cells(SheetrowF, 8) = s.Name 'successor task names to excel
<wbr> Else 'append next successor
<wbr> mysheetF.Cells(SheetrowF, 8) = mysheetF.Cells(SheetrowF, 8) & "," & s.Name
<wbr> End If
Next s
mysheetF.Cells(SheetrowF, 9) = t.Text19 'mitigation text
mysheetF.Cells(SheetrowF, 10) = t.TotalSlack / 480 & " d" 'float in days
mysheetF.Cells(SheetrowF, 11) = "R" 'status R or A
If t.TotalSlack > 0 Then mysheetF.Cells(SheetrowF, 11) = "A"
SheetrowF = SheetrowF + 1
End If
End If
End If
End If
End If
Next t
mysheetF.Columns.AutoFit
mysheetS.Columns.AutoFit
mysheetC.Columns.AutoFit
AppActivate "Microsoft Project"
MsgBox ("Report Complete")
AppActivate "Microsoft Excel"
End Sub
Private Sub ExcelTopLine(mysheet As Excel.Worksheet, mytype As Integer)
'Excel Titles
mysheet.Cells(1, 1) = "ID"
mysheet.Cells(1, 2) = "Workstream"
mysheet.Cells(1, 3) = "Activity Description"
mysheet.Cells(1, 4) = "Baseline Start Date"
mysheet.Cells(1, 5) = "Revised Start Date"
If mytype = 1 Then
mysheet.Cells(1, 4) = "Baseline Finish Date"
mysheet.Cells(1, 5) = "Revised Finish Date"
ElseIf mytype = 3 Then
mysheet.Cells(1, 4) = "Planned Finish Date"
mysheet.Cells(1, 5) = "Actual Finish Date"
End If
If mytype < 3 Then
mysheet.Cells(1, 6) = "Slippage from Orig. Baseline"
mysheet.Cells(1, 7) = "Last Week's Finish Date"
If mytype = 2 Then mysheet.Cells(1, 7) = "Last Week's Start Date"
mysheet.Cells(1, 8) = "Impacted Successor"
mysheet.Cells(1, 9) = "Actions to mitigate"
mysheet.Cells(1, 10) = "Float"
mysheet.Cells(1, 11) = "Status"
Else
mysheet.Cells(1, 6) = "Impacted Successor"
End If
appXL.DisplayAlerts = False
With mysheet.Range("A1:K1")
With .Interior
.ColorIndex = 35
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
.Font.Bold = True
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
appXL.DisplayAlerts = True
mysheet.Columns("D:E").<wbr>NumberFormat = "dd/mm/yyyy"
If mytype < 3 Then mysheet.Columns("G:G").<wbr>NumberFormat = "dd/mm/yyyy"
End Sub
Kind regards
Zeni
I am trying to extract information from project to excel and do this via code. This is something that has to be continuously done as the project rolls on so doing it manually will take too much time. I have posted the code below that I have managed to piece together via perusing the internet, however when I run the code I get the error: " user defined type not defined". Any help is much appreciated, thank you so much in advance
Dim appXL As Excel.Application
Sub StonePlanStatusReport()
Dim t As Task
Dim s As Task
Dim tCurrentFinish As Date
Dim tLastFinish As Date
Dim tCurrentStart As Date
Dim tLastStart As Date
Dim MyWorkbook As Excel.Workbook
Dim mysheetF As Excel.Worksheet
Dim mysheetS As Excel.Worksheet
Dim mysheetC As Excel.Worksheet
Dim SheetrowF As Integer
Dim SheetrowS As Integer
Dim SheetrowC As Integer
Dim mytype As Integer
Dim lastbase As Integer
Dim olderbase As Integer
Dim NewReportCycle As Boolean
'Create the Excel Application
On Error Resume Next
Set appXL = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set appXL = CreateObject("Excel.<wbr>application")
End If
appXL.Visible = True
Set MyWorkbook = appXL.Workbooks.Add
'find which baseline is later
lastbase = 1
olderbase = 2
If ActiveProject.<wbr>BaselineSavedDate(pjBaseline2) > ActiveProject.<wbr>BaselineSavedDate(pjBaseline1) Then
lastbase = 2
olderbase = 1
End If
mytype = 1 'delayed finish sheet
Set mysheetF = MyWorkbook.Sheets(mytype)
mysheetF.Name = "Delayed Activities - Finish"
Call ExcelTopLine(mysheetF, mytype) 'headers
SheetrowF = 2
mytype = 2 'delayed start sheet
Set mysheetS = MyWorkbook.Sheets.Add
mysheetS.Name = "Delayed Activities - Start"
Call ExcelTopLine(mysheetS, mytype) 'headers
SheetrowS = 2
mytype = 3 'completed activities sheet
Set mysheetC = MyWorkbook.Sheets.Add
mysheetC.Name = "Completed Activities"
Call ExcelTopLine(mysheetC, mytype) 'headers
SheetrowC = 2
'initialise Flag20
For Each t In ActiveProject.Tasks
If Not t Is Nothing Then 'ignore blank lines
t.Flag20 = False
End If
Next t
'check if new report cycle
NewReportCycle = False
If ActiveProject.Tasks(1).Date10 <= ActiveProject.<wbr>BaselineSavedDate(olderbase) Then
NewReportCycle = True
ActiveProject.Tasks(1).Date10 = ActiveProject.<wbr>BaselineSavedDate(lastbase)
End If
'first work out which tasks should be in report
For Each t In ActiveProject.Tasks
If Not t Is Nothing Then 'ignore blank lines
If Not t.Summary Then 'only look at tasks
If t.Flag20 Then 'check if already excluded
For Each s In t.SuccessorTasks
s.Flag20 = True 'so exclude successors
Next s
Else 'if not already excluded, check if replanned
If lastbase = 1 Then
tCurrentStart = t.Baseline1Start
tLastStart = t.Baseline2Start
tCurrentFinish = t.Baseline1Finish
tLastFinish = t.Baseline2Finish
Else
tCurrentStart = t.Baseline2Start
tLastStart = t.Baseline1Start
tCurrentFinish = t.Baseline2Finish
tLastFinish = t.Baseline1Finish
End If
If tCurrentFinish > tLastFinish Or tCurrentStart > tLastStart Then 'replanned, so exclude successors
For Each s In t.SuccessorTasks
s.Flag20 = True 'exclude successors
Next s
End If
End If
End If
End If
Next t
'now do reports
For Each t In ActiveProject.Tasks
If Not t Is Nothing Then 'ignore blank lines
If Not t.Summary Then 'only look at tasks
If Not t.Flag19 Then 'task not previously complete
If t.PercentComplete = 100 Then 'write record to excel sheet
mysheetC.Cells(SheetrowC, 1) = t.ID 'ID
mysheetC.Cells(SheetrowC, 2) = Mid(t.Project, 7) 'project
mysheetC.Cells(SheetrowC, 3) = t.Name & " for " & t.OutlineParent.OutlineParent.<wbr>Name & " for " & t.OutlineParent.Name'description (with summary info)
mysheetC.Cells(SheetrowC, 4) = t.BaselineFinish 'baseline finish
If t.BaselineFinish = "NA" Then 'use Baseline3 if required
mysheetC.Cells(SheetrowC, 4) = t.Baseline3Finish
End If
mysheetC.Cells(SheetrowC, 5) = t.Finish 'finish
For Each s In t.SuccessorTasks
If mysheetC.Cells(SheetrowC, 6) = "" Then
<wbr> mysheetC.Cells(SheetrowC, 6) = s.Name 'successor task names to excel
Else 'append next successor
<wbr> mysheetC.Cells(SheetrowC, 6) = mysheetC.Cells(SheetrowC, 6) & "," & s.Name
End If
Next s
SheetrowC = SheetrowC + 1
If NewReportCycle Then t.Flag19 = True 'set flag for next cycle
End If
End If
If Not t.Flag20 Then 'look for tasks not flagged
'and check if delayed
If lastbase = 1 Then
tCurrentStart = t.Baseline1Start
tLastStart = t.Baseline2Start
tCurrentFinish = t.Baseline1Finish
tLastFinish = t.Baseline2Finish
Else
tCurrentStart = t.Baseline2Start
tLastStart = t.Baseline1Start
tCurrentFinish = t.Baseline2Finish
tLastFinish = t.Baseline1Finish
End If
'check start date first
If tCurrentStart > tLastStart Then 'start delayed, so populate excel sheet with data
mysheetS.Cells(SheetrowS, 1) = t.ID 'ID
mysheetS.Cells(SheetrowS, 2) = Mid(t.Project, 7) 'project
mysheetS.Cells(SheetrowS, 3) = t.Name & " for " & t.OutlineParent.OutlineParent.<wbr>Name & " for " & t.OutlineParent.Name'description (with summary info)
mysheetS.Cells(SheetrowS, 4) = t.BaselineStart 'baseline start
mysheetS.Cells(SheetrowS, 5) = t.Start 'start
mysheetS.Cells(SheetrowS, 6) = t.StartVariance / 480 & " d" 'slippage in days
If t.BaselineStart = "NA" Then 'use Baseline3 if required
t.BaselineStart = t.Baseline3Start
mysheetS.Cells(SheetrowS, 4) = t.BaselineStart 'baseline start
mysheetS.Cells(SheetrowS, 6) = t.StartVariance / 480 & " d" 'slippage in days
t.BaselineStart = "NA"
End If
mysheetS.Cells(SheetrowS, 7) = tLastStart 'previous week's start date
For Each s In t.SuccessorTasks
If mysheetS.Cells(SheetrowS, 8) = "" Then
<wbr> mysheetS.Cells(SheetrowS, 8) = s.Name 'successor task names to excel
Else 'append next successor
<wbr> mysheetS.Cells(SheetrowS, 8) = mysheetS.Cells(SheetrowS, 8) & "," & s.Name
End If
Next s
mysheetS.Cells(SheetrowS, 9) = t.Text19 'mitigation text
mysheetS.Cells(SheetrowS, 10) = t.TotalSlack / 480 & " d" 'float in days
mysheetS.Cells(SheetrowS, 11) = "R" 'status R or A
If t.TotalSlack > 0 Then mysheetS.Cells(SheetrowS, 11) = "A"
SheetrowS = SheetrowS + 1
Else 'start not delayed, so check finish date
If tCurrentFinish > tLastFinish Then 'finish delayed, so populate excel sheet with data
mysheetF.Cells(SheetrowF, 1) = t.ID 'ID
mysheetF.Cells(SheetrowF, 2) = Mid(t.Project, 7) 'project
mysheetF.Cells(SheetrowF, 3) = t.Name & " for " & t.OutlineParent.OutlineParent.<wbr>Name & " for " & t.OutlineParent.Name'description (with summary info)
mysheetF.Cells(SheetrowF, 4) = t.BaselineFinish 'baseline finish
mysheetF.Cells(SheetrowF, 5) = t.Finish 'finish
mysheetF.Cells(SheetrowF, 6) = t.FinishVariance / 480 & " d" 'slippage in days
If t.BaselineFinish = "NA" Then 'use Baseline3 if required
<wbr> t.BaselineFinish = t.Baseline3Finish
<wbr> mysheetF.Cells(SheetrowF, 4) = t.BaselineFinish 'baseline finish
<wbr> mysheetF.Cells(SheetrowF, 6) = t.FinishVariance / 480 & " d" 'slippage in days
<wbr> t.BaselineFinish = "NA"
End If
mysheetF.Cells(SheetrowF, 7) = tLastFinish 'previous week's finish date
For Each s In t.SuccessorTasks
<wbr> If mysheetF.Cells(SheetrowF, 8) = "" Then
<wbr> mysheetF.Cells(SheetrowF, 8) = s.Name 'successor task names to excel
<wbr> Else 'append next successor
<wbr> mysheetF.Cells(SheetrowF, 8) = mysheetF.Cells(SheetrowF, 8) & "," & s.Name
<wbr> End If
Next s
mysheetF.Cells(SheetrowF, 9) = t.Text19 'mitigation text
mysheetF.Cells(SheetrowF, 10) = t.TotalSlack / 480 & " d" 'float in days
mysheetF.Cells(SheetrowF, 11) = "R" 'status R or A
If t.TotalSlack > 0 Then mysheetF.Cells(SheetrowF, 11) = "A"
SheetrowF = SheetrowF + 1
End If
End If
End If
End If
End If
Next t
mysheetF.Columns.AutoFit
mysheetS.Columns.AutoFit
mysheetC.Columns.AutoFit
AppActivate "Microsoft Project"
MsgBox ("Report Complete")
AppActivate "Microsoft Excel"
End Sub
Private Sub ExcelTopLine(mysheet As Excel.Worksheet, mytype As Integer)
'Excel Titles
mysheet.Cells(1, 1) = "ID"
mysheet.Cells(1, 2) = "Workstream"
mysheet.Cells(1, 3) = "Activity Description"
mysheet.Cells(1, 4) = "Baseline Start Date"
mysheet.Cells(1, 5) = "Revised Start Date"
If mytype = 1 Then
mysheet.Cells(1, 4) = "Baseline Finish Date"
mysheet.Cells(1, 5) = "Revised Finish Date"
ElseIf mytype = 3 Then
mysheet.Cells(1, 4) = "Planned Finish Date"
mysheet.Cells(1, 5) = "Actual Finish Date"
End If
If mytype < 3 Then
mysheet.Cells(1, 6) = "Slippage from Orig. Baseline"
mysheet.Cells(1, 7) = "Last Week's Finish Date"
If mytype = 2 Then mysheet.Cells(1, 7) = "Last Week's Start Date"
mysheet.Cells(1, 8) = "Impacted Successor"
mysheet.Cells(1, 9) = "Actions to mitigate"
mysheet.Cells(1, 10) = "Float"
mysheet.Cells(1, 11) = "Status"
Else
mysheet.Cells(1, 6) = "Impacted Successor"
End If
appXL.DisplayAlerts = False
With mysheet.Range("A1:K1")
With .Interior
.ColorIndex = 35
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
.Font.Bold = True
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
appXL.DisplayAlerts = True
mysheet.Columns("D:E").<wbr>NumberFormat = "dd/mm/yyyy"
If mytype < 3 Then mysheet.Columns("G:G").<wbr>NumberFormat = "dd/mm/yyyy"
End Sub
Kind regards
Zeni
