Custom Milestone report

[Jesse]

I have a couple project schedules with over 1,000 milestones. The majority of
the milestones have at least 1 predecessor and many have 4 or 5 predecessors.
I needed an easy way to evaluate the complete% of the predecessors to see if
the milestone should be closed. I created an Excel macro that reads some data
exported from a project schedule and returns each milestone with its
predecessors listed below it with their complete%. This has been extremely
useful -- but I want to see if there's a way to do this within MS Project
2003 using a macro. I'm hoping someone else see's the value of this that has
some MS Project programming skills that can create a contained macro that I
can use.

What I do is:
- do a File/Save As from Project to Excel
- select ID, %complete, Name, Milestone (y/n), Predecessor, Late (custom
field), and Resource Name
- I copy the data from the target Excel into the Main table in the Milestone
xls
- I run the macro below to produce the other 2 tables

Sub foo()
Dim i, ID As String
Dim pred As String
Dim numValue As Boolean
curRow = 1
curtask = 1
Sheet2.ListObjects("Milestone").DataBodyRange.Delete
Sheet2.ListObjects("Tasks").DataBodyRange.Delete

For Each Cell In Sheet1.ListObjects("Main").ListColumns("Milestone").Range
If Cell.Value = "Yes" Then
ID = Cell.Offset(0, -3).Value
Sheet2.ListObjects("Tasks").ListRows.Add
Sheet2.ListObjects("Tasks").ListRows(curtask).Range.Font.Bold =
True
Sheet2.ListObjects("Tasks").ListRows(curtask).Range.Font.Italic
= False

Sheet2.ListObjects("Tasks").ListRows(curtask).Range.Interior.ColorIndex = 15

Sheet2.ListObjects("Tasks").ListRows(curtask).Range.Cells(1).Value = ID

Sheet2.ListObjects("Tasks").ListRows(curtask).Range.Cells(2).Value =
"=vlookup(" & ID & ",main,2)"

Sheet2.ListObjects("Tasks").ListRows(curtask).Range.Cells(3).Value =
"=vlookup(" & ID & ",main,3)"

Sheet2.ListObjects("Tasks").ListRows(curtask).Range.Cells(4).Value =
"=vlookup(" & ID & ",main,6)"

Sheet2.ListObjects("Tasks").ListRows(curtask).Range.Cells(5).Value =
"=vlookup(" & ID & ",main,7)"

curtask = curtask + 1

For j = 1 To Cell.Offset(0, 1).Characters.Count
If Cell.Offset(0, 1).Characters(j, 1).Text <> "," Then
If numValue Then
If Not IsNumeric(Cell.Offset(0, 1).Characters(j,
1).Text) Then
numValue = False
Else
pred = pred & Cell.Offset(0, 1).Characters(j,
1).Text
End If
End If
Else
numValue = True
Sheet2.ListObjects("Milestone").ListRows.Add

Sheet2.ListObjects("Milestone").ListRows(curRow).Range.Cells(1).Value = ID

Sheet2.ListObjects("Milestone").ListRows(curRow).Range.Cells(2).Value = pred
curRow = curRow + 1

Sheet2.ListObjects("Tasks").ListRows.Add

Sheet2.ListObjects("Tasks").ListRows(curtask).Range.Interior.ColorIndex =
XlColorIndex.xlColorIndexNone

Sheet2.ListObjects("Tasks").ListRows(curtask).Range.Font.Bold = False

Sheet2.ListObjects("Tasks").ListRows(curtask).Range.Font.Italic = True

Sheet2.ListObjects("Tasks").ListRows(curtask).Range.Cells(1).Value = pred

Sheet2.ListObjects("Tasks").ListRows(curtask).Range.Cells(2).Value =
"=vlookup(" & pred & ",main,2)"

Sheet2.ListObjects("Tasks").ListRows(curtask).Range.Cells(3).Value =
"=vlookup(" & pred & ",main,3)"

Sheet2.ListObjects("Tasks").ListRows(curtask).Range.Cells(4).Value =
"=vlookup(" & pred & ",main,6)"

Sheet2.ListObjects("Tasks").ListRows(curtask).Range.Cells(5).Value =
"=vlookup(" & pred & ",main,7)"
curtask = curtask + 1

pred = ""
End If
Next j

numValue = True
Sheet2.ListObjects("Milestone").ListRows.Add

Sheet2.ListObjects("Milestone").ListRows(curRow).Range.Cells(1).Value = ID

Sheet2.ListObjects("Milestone").ListRows(curRow).Range.Cells(2).Value = pred
curRow = curRow + 1

If pred <> "" Then
Sheet2.ListObjects("Tasks").ListRows.Add

Sheet2.ListObjects("Tasks").ListRows(curtask).Range.Interior.ColorIndex =
XlColorIndex.xlColorIndexNone

Sheet2.ListObjects("Tasks").ListRows(curtask).Range.Font.Bold = False

Sheet2.ListObjects("Tasks").ListRows(curtask).Range.Font.Italic = True

Sheet2.ListObjects("Tasks").ListRows(curtask).Range.Cells(1).Value = pred

Sheet2.ListObjects("Tasks").ListRows(curtask).Range.Cells(2).Value =
"=vlookup(" & pred & ",main,2)"

Sheet2.ListObjects("Tasks").ListRows(curtask).Range.Cells(3).Value =
"=vlookup(" & pred & ",main,3)"
curtask = curtask + 1

pred = ""
End If
End If
Next Cell

MsgBox ("All Done")

End Sub

 

[Jan De Messemaeker]

Hi Jesse,

The following snippet gives you the predecessors of any milestone, one by
one:

Dim Anytask as task
Dim predeces as task

for each anytask in activeproject.tasks
if not anytask is nothing then
if anytask.milestone then
for each predeces in anytask.predecessortasks
' Here you have the predecessor task at your disposal to calculate
'You can use properties such as duration, actualduration, percentcomplete...
next predeces
end if 'milestone
end if 'nothing
next anytask

Good luck!

 

[JackD]

For another example go to http://masamiki.com/project/macros.htm
and look at the "ready to start" macro.
It is very similar to Jan's, but sets a flag and a filter. That should cover
just about all you need.

-Jack Dahlgren
http://zo-d.com/blog/