Mitigating % Complete and Duration Headaches (Project VBA)

Most of our projects are setup as Fixed Unit, non-effort driven tasks in MSP (Note: We also setup our schedules with the Updating task status updates resource status, located under the Calculation tab, checked).

When entering status for a task, we update (primarily) two fields: % Complete and/or Duration.  Changing the Duration field will affect the % Complete field in 2 ways:

1. Decreasing the Duration will increase the % Complete field;
2. Increasing the Duration will decrease the % Complete field.

Often we do not want to change % Complete, but adjust the Duration and maintain our current % Complete. We track performance using % Complete (for better or for worse, and yes I'm aware of using % Work Complete to track actual track progress...), so we are extra cautious with any negative changes in % Complete.  Why?  Well, let's just say reporting negative performance to the customer is not a positive experience.

Although we take extra steps to ensure we don't inadvertently decrease performance (though we do make the downward adjustment if appropriate, god forbid), we all have a habit of falling into the debacle that is colloquially known as "month end swirl".  Only the strong survive, and those that do are permanently scarred. 

I wrote the code below to speed up entering status and reduce schedule rework.  I have the macro set to my Ctrl-A shortcut in MSP.  To run the code select your task you want to update, and run the macro.  The code will pop-up an input box asking for the task's new duration.  The code will adjust your the task to your new duration while maintaining the previous % Complete.

Option Explicit
'---------------------------------------------------------------------------------------
' Procedure : NewDuration
' Author    : Business Bear
' Date      : 1/23/2012
' Purpose   : http://www.yunolikeexcel.com
'             This code will adjust your the task to your new duration
'             while maintaining the previous % Complete.
'             Setting the finish date to a date prior to the start date
'             will turn the task into a milestone.
'---------------------------------------------------------------------------------------
'
Sub NewDuration()

    Dim dCurStart As Date
    Dim vFinishDate As Variant
    Dim dNewFinish As Date
    Dim dCurFinish As Date
    Dim pj As Project
    Dim lNewDuration As Long
    Dim ac As Cell
    Dim lPctCompl As Long
    Dim vMsgBoxResp As Variant
   
    'Adjust conlMinutesInDay constant to reflect the number of minutes/day
    'in your schedule.  We use 8hrs/day so 8Hrs*60min = 480min/day
    Const conlMinutesInDay As Long = 480
    Const convMsgBoxButtons As Variant = vbYesNo + vbSystemModal + vbExclamation
    Const consMsgBoxTitle As String = "Warning"
    Const consDateFormat As String = "mm/dd/yyyy"
    Const consInputBxTitle As String = "New Finish Date?"
   
    'prevent code from running if no active project
    On Error GoTo EndMacro
    Set pj = ActiveProject
    On Error GoTo 0
    Set ac = ActiveCell
    Set t = ac.Task

    'prevent code from running if no task selected
    If t Is Nothing Then GoTo EndMacro
    dCurStart = t.Start
    dCurFinish = t.Finish
    lPctCompl = t.PercentComplete

    'loop until user enters a valid date
    'if user enters nothing exit procedure
    Do
        vFinishDate = InputBox(consInputBxTitle)
        If vFinishDate = vbNullString Then
            GoTo EndMacro
            Exit Do
        End If
    Loop Until IsDate(vFinishDate)

    '=== DateDifference returns minutes; divide by 480 for days
    lNewDuration = Application.DateDifference(StartDate:=dCurStart, _
            FinishDate:=vFinishDate) / conlMinutesInDay
    dNewFinish = Application.DateAdd(StartDate:=dCurStart, _
            Duration:=lNewDuration * conlMinutesInDay)
    If Format(dNewFinish, consDateFormat) <> vFinishDate Then
        If dNewFinish < vFinishDate Then
            lNewDuration = lNewDuration + 1
        ElseIf dNewFinish > dCurFinish Then
            lNewDuration = lNewDuration - 1
        End If
    End If

    '=== Set New finish date for testing against old finish date
    dNewFinish = Application.DateAdd(StartDate:=dCurStart, _
            Duration:=lNewDuration * conlMinutesInDay)
    If dCurFinish > dNewFinish Then
        vMsgBoxResp = MsgBox(Prompt:="Old finish date (" & Format(dCurFinish, _
                consDateFormat) & ") is after selected Finish Date (" & Format(dNewFinish, _
                consDateFormat) & ")." & vbCrLf & vbCrLf & "Continue?", _
                Buttons:=convMsgBoxButtons, Title:=consMsgBoxTitle)
        If vMsgBoxResp = vbYes Then
            'User wants to update even though date is in past
            GoTo Continue
        Else
            'User opted to exit
            GoTo EndMacro
        End If
    End If

Continue:
    t.Duration = lNewDuration * conlMinutesInDay
    t.PercentComplete = lPctCompl

EndMacro:
    Set pj = Nothing
    Set vFinishDate = Nothing
End Sub