MS Project 2013: display resources on summary tasks

旧时模样 提交于 2019-12-02 11:16:35

Those resource fields exist at the summary level because you can directly assign resources to a summary task, so you can't use those fields for this purpose. However, here's a macro that aggregates the names of the resources assigned to the subtasks. The results are put in Text1 at the summary level. You can then modify the Gantt chart bar styles to show that text field.

Sub RollupResourceNames()

    Dim tsk As Task
    Dim list As String
    Dim key As Variant

    For Each tsk In ActiveProject.Tasks
        If tsk.Summary Then
            Dim col As New Collection
            Set col = GetChildResourceAssignments(tsk)
            list = vbNullString
            For Each key In col
                list = list & ", " & key
            Next
            If Len(list) > 2 Then
                list = Mid$(list, 3)
            End If
            tsk.Text1 = list
        End If
    Next tsk

End Sub

Function GetChildResourceAssignments(parent As Task) As Collection

    Dim col As New Collection

    Dim child As Task
    Dim asn As Assignment
    For Each child In parent.OutlineChildren
        If child.Summary Then
            Dim col2 As New Collection
            Set col2 = GetChildResourceAssignments(child)
            Dim key As Variant
            For Each key In col2
                col.Add key, key
            Next key
        End If
        For Each asn In child.Assignments
            On Error Resume Next
            col.Add asn.Resource.Name, asn.Resource.Name
            On Error GoTo 0
        Next asn
    Next child

    Set GetChildResourceAssignments = col

End Function

@Rachel Hettinger - Solution works great, except it will error out (error 457) if you have multiple levels of parent/child tasks and the same resource is present across different levels. It tries to add the resource name to the collection, but it already exists (since it was added earlier when the script checked the other set of tasks) and doesn't know what to do.

This is fixable by simply adding another "On Error Resume Next" line. Here is the revised macro, which works perfectly on my Project Plan. All credit to Rachel Hettinger here, I just added one line!

Sub RollupResourceNames()

    Dim tsk As Task
    Dim list As String
    Dim key As Variant

    For Each tsk In ActiveProject.Tasks
        If tsk.Summary Then
            Dim col As New Collection
            Set col = GetChildResourceAssignments(tsk)
            list = vbNullString
            For Each key In col
                list = list & ", " & key
            Next
            If Len(list) > 2 Then
                list = Mid$(list, 3)
            End If
            tsk.Text1 = list
        End If
    Next tsk

End Sub

Function GetChildResourceAssignments(parent As Task) As Collection

    Dim col As New Collection

    Dim child As Task
    Dim asn As Assignment
    For Each child In parent.OutlineChildren
        If child.Summary Then
            Dim col2 As New Collection
            Set col2 = GetChildResourceAssignments(child)
            Dim key As Variant
            For Each key In col2
                On Error Resume Next
                col.Add key, key
            Next key
        End If
        For Each asn In child.Assignments
            On Error Resume Next
            col.Add asn.Resource.Name, asn.Resource.Name
            On Error GoTo 0
        Next asn
    Next child

    Set GetChildResourceAssignments = col

End Function
标签
易学教程内所有资源均来自网络或用户发布的内容,如有违反法律规定的内容欢迎反馈
该文章没有解决你所遇到的问题?点击提问,说说你的问题,让更多的人一起探讨吧!