PPC Macro
Here is a first pass at the Percent of Promises Complete macro I talked about. It looks a little funny because of the way my blog is formatted but it pastes into the VBA window directly from the browser. If you have problems let me know via email (brian.kennemer@gmail.com) and I will send it to you in a text file.
Sub PPC()
Dim P As Project
Dim T As Task
Dim Promised As Integer
Dim Delivered As Integer
Dim PPC As Long
Set P = Application.ActiveProject
'Check to see if there is a status date
If P.StatusDate = "NA" Then
MsgBox Prompt:="There is no status date for the project" & Chr(13) _
& "You must save a Status Date to calculate PPC"
End If
'Loop through all tasks
For Each T In P.Tasks
If Not (T Is Nothing) Then
'Check to see if the task has a baseline saved. If it does not then
'stop the macro.
If T.BaselineFinish = "NA" Then
MsgBox Prompt:="Task ID " & T.ID & " does not have a baseline saved" _
& Chr(13) & "You must save a baseline for all tasks to calculate PPC"
End
End If
'Check to see if the baseline finish is less than or equal to the status date
'If it is then increment Promised
If T.BaselineFinish = P.StatusDate Or T.BaselineFinish < P.StatusDate Then
Promised = Promised + 1
'Check to see if the promised task is complete.
'If it is then increment Delivered
If T.PercentComplete = 100 Then
Delivered = Delivered + 1
End If
End If
End If
Next T
'Calculate PPC
PPC = (Delivered / Promised) * 100
'Loop back through and set Text 20 to be equal to PPC
For Each T In ActiveProject.Tasks
If Not (T Is Nothing) Then
T.Text20 = PPC & "%"
End If
Next T
End Sub
Comments