How to Update a Microsoft Project Sub-Project Using VBA

user_2264225 0
Viewed 196

We are attempting to update the status date in the sub-projects of a Schedule using VBA following the suggestions here and here. Ideally we'd like to keep the files closed while doing so, but are open to suggestions if that isn't strictly possible.

The relevant code looks like this:

If ActiveProject.Subprojects.count > 0 Then
    Dim msg: msg = MsgBox("Change Status Date for unopened Subprojects?", vbYesNo, "Change Status Dates for Unopened Subprojects?")
    Dim subp As SubProject
    If msg = vbYes Then
        Application.StatusBar = "Updating Sub-Projects..."
        For Each subp In ActiveProject.Subprojects
            subp.SourceProject.StatusDate = newDate
            subp.SourceProject.SaveAs subp.SourceProject.Name
        Next
    End If
End If

This appears to work, however when we open the sub-project files the Status Date hasn't changed (as seen on Project > Status > Status Date). The date below is the same before and after:

enter image description here

Alternatives that also have not worked.

  1. We've tried setting Projects(subp.SourceProject.Name).StatusDate:
If ActiveProject.Subprojects.count > 0 Then
    Dim msg: msg = MsgBox("Change Status Date for unopened Subprojects?", vbYesNo, "Change Status Dates for Unopened Subprojects?")
    Dim subp As SubProject
    If msg = vbYes Then
        Application.StatusBar = "Updating Sub-Projects..."
        For Each subp In ActiveProject.Subprojects
            Projects(subp.SourceProject.Name).StatusDate = newDate
            subp.SourceProject.SaveAs subp.SourceProject.Name
        Next
    End If
End If
  1. We've tried to open the sub-projects first and then to change the value (we've tried both FileOpen & FileOpenEx):
If ActiveProject.Subprojects.count > 0 Then
    Dim msg: msg = MsgBox("Change Status Date for unopened Subprojects?", vbYesNo, "Change Status Dates for Unopened Subprojects?")
    Dim subp As SubProject
    If msg = vbYes Then
        Application.StatusBar = "Updating Sub-Projects..."
        For Each subp In ActiveProject.Subprojects
            FileOpen subp.SourceProject.Path
            subp.SourceProject.StatusDate = newDate
            FileClose pjSave
        Next
    End If
End If
  1. And then we've tried saving the sub-projects in various ways using:

  • subp.SourceProject.SaveAs subp.SourceProject.Name

  • Projects(subp.SourceProject.path).SaveAs subp.SourceProject.Name

As an interesting data point, we do notice that both the SourceProject.StatusDate and Projects(subp.SourceProject.Name).StatusDate for a given sub-project are what we set them to, even if the sub-project, once opened in MSP, does not reflect the value in the interface.

Note: we have tried closing/re-opening and manual save all (user input). No go.

Any suggestions are more than welcome.

EDIT #1

Note that we have also attempted saving the master schedule following the loop using two methods.

First, code leading up to the save:

    'save name of Master Schedule to imsProj
    dim imsProj as string: imsProj = ActiveProj.Name 
    If ActiveProject.Subprojects.count > 0 Then
         'Here is where we run the above loop
    End If
    
    'Ensure the Master Schedule is the active project
    Projects(imsProj).Activate

    'Master Schedule save goes here. See below.

Then:

Save Method 1

    'Save all open Projects, including master
    For i = 1 To Projects.count
        Projects(i).SaveAs Projects(i).Name
    Next i

Save Method 2:

FileSave

Neither works.

Is there a setting in MSP that we are not considering?

ms-project ms-office vba
2 Answers

Instead of trying to save each subproject individually, save the entire master at the end. Turning of alerts prevents a pop-up confirmation box for each subproject.

Sub SetSubProjectStatusDate()

Dim newDate As Date
newDate = #1/11/2022#

If ActiveProject.Subprojects.Count > 0 Then
    Dim msg As VbMsgBoxResult
    msg = MsgBox("Change Status Date for unopened Subprojects?", vbYesNo + vbQuestion _
        , "Change Status Dates?")
    If msg = vbYes Then
        Application.StatusBar = "Updating Sub-Projects..."
        Dim subp As Subproject
        For Each subp In ActiveProject.Subprojects
            subp.SourceProject.StatusDate = newDate
        Next
        DisplayAlerts = False
        FileSave
        DisplayAlerts = True
    End If
End If

End Sub
user_10566320

This is incredibly frustrating, but it appears the IMS and its subprojects were somehow corrupted. No evident cause, no evident effect other than with how the status dates appear. Using a fresh set of MPPs resolved the matter.

Here is the final working code:

If ActiveProject.Subprojects.count > 0 Then
    Dim msg: msg = MsgBox("Change Status Date for unopened Subprojects?", vbYesNo, "Change Status Dates for Unopened Subprojects?")
    Dim subp As SubProject
    If msg = vbYes Then
        Application.StatusBar = "Updating Sub-Projects..."
        For Each subp In ActiveProject.Subprojects
            subp.SourceProject.StatusDate = temp
        Next
    End If
End If

Projects(imsProj).Activate

FileSave
user_22642250
Related