news and know-how about microsoft, technology, cloud and more.

Project: Zuordnungseinheiten neu berechnen / Recalculate Assignment Units

  1. Deutsch
  2. English
  3. Code


Im Artikel Zuordnungseinheiten in Project ab Version 2010 ist beschrieben, weshalb die Anzeige der Zuordnungseinheiten bei der Änderung von Dauer oder Arbeit ab Project 2010 nicht aktualisiert wird. Rod Gill aus Australien hat dazu ein Makro zur Verfügung gestellt, mit dem die Neuberechnung der Zuordnungseinheiten erfolgen kann: Reset Assignment Units. In Europa verwenden wir jedoch andere Regionaleinstellungen, daher finden Sie hier eine modifizierte Version.

In Makros implementieren / Implement Macros wird beschrieben, wie ein Makro in Project übernommen werden kann.Mehr Beispielmakros sind unter VBA zu finden.


The article Assignment Units in Project 2010 describes why the display of the assignment units is not updated when changing the duration or the work as of Project 2010. Rod Gill from Australia has provided a macro that can be used to recalculate the allocation units: Reset Assignment Units. In Europe, however, we use different regional settings, so you will find here a modified version.

Implementing Macros / Implement Macros describes how to apply a macro to Project. More sample code is available at VBA.


Sub RefreshUnits()
    'Code is provided "AS IS" without warranty of any kind, either expressed or implied,
    'including but not limited to the implied warranties of merchantability and/or
    'fitness for a particular purpose.
        Dim Tsk As Task
        Dim Assgn As Assignment
        Dim v_Version As Integer
        Dim v_StartDate As Date
        Dim v_TaskType As Long
        Dim v_Work As Long
        Dim v_v_MsgText As String
        'Originally developed by Rod Gill - thanks for providing!!!
        'This macro runs on active Project 2010 and higher only.
        'Information for Assignmentunit Change at
        'Modifications by Barbara Henhapl,
        ' 1. Undo implemented
        ' 2. Enable different regional settings
        'Please distribute with reference to
        ' only
        'Check version, with respect to regional settings
            If CInt(Replace(Application.Version, ".", Application.DecimalSeparator)) < 14 Then
                Select Case Application.LocaleID
                    Case 1031 'German
                        v_MsgText = "Dieses Makro ist nur für Project 2010 und höher sinnvoll, " _
                            & "daher wird das Makro nun beendet."
                    Case 1036  'French
                       v_MsgText = "Cette macro n'est utile que pour Project 2010 et les " _
                            & "versions ultérieures. Elle sera donc terminée."
                    Case 1043  'Dutch
                       v_MsgText = "Deze macro is alleen nuttig voor Project 2010 en later," _
                            & " dus de macro wordt nu beëindigd."
                    Case Else ' English and other
                        v_MsgText = "This macro is only useful for Project 2010 and later," _
                            & " so macro is ended."
                End Select
                MsgBox v_MsgText, vbCritical + vbOKOnly
                'Open a transaction to enable "Undo"
                Application.OpenUndoTransaction ("Refresh Units")
                For Each Tsk In ActiveProject.Tasks
                    If Not Tsk Is Nothing Then
                        'Only adjust Units for an Auto, incomplete, non-summary and active Task,
                        'with Assignments
                        If Tsk.PercentComplete < 100 _
                            And Not Tsk.Summary _
                            And Tsk.Active _
                            And Tsk.Manual = False _
                            And Tsk.Assignments.Count > 0 Then 'no action required for tasks
                            'without assignment
                            'For recalculation of AssignmentUnits Task Type "Fixed Duration"
                            'is required.
                            'The original Task Type has to be set afterwards, keep the value
                            v_TaskType = Tsk.Type
                            Tsk.Type = pjFixedDuration
                            For Each Assgn In Tsk.Assignments
                                'Only adjust tasks not yet completed
                                If Assgn.PercentWorkComplete < 100 Then
                                    'Get the resume date for CompletedThrough
                                    If Assgn.PercentWorkComplete > 0 Then
                                        v_StartDate = Tsk.Resume  'This is not necessarily
                                                                  'accurate but is close enough
                                        v_StartDate = Assgn.Start
                                    End If
                                    'Keep work, since it will change during the following steps
                                    v_Work = Assgn.Work
                                    'IMPORTANT: For calculation of Remaining Duration, function
                                    'Application.DateDifference has to be used, since only this
                                    'function respects calendar exceptionsücksichtigt
                                    'If resource calendar are not set to "ignore", this calendar
                                    'has to be respected for calculation of Remaining Duration.
                                    'if there is no task calendar applied, Project calendar is
                                    'applied implicitely as task calendar
                                    If Not Tsk.IgnoreResourceCalendar Then
                                        RemDur = Application.DateDifference _
                                        (v_StartDate, Assgn.Finish, Assgn.Resource.Calendar)
                                        RemDur = Application.DateDifference _
                                        (v_StartDate, _
                                         Assgn.Finish, _
                                    End If
                                    'If there is RemainingDuration, AssignmentUnits are recalculated.
                                    'Afterwards, Assignment Work has to be set to the original value
                                    If RemDur > 0 Then
                                        Assgn.Units = Assgn.RemainingWork / RemDur
                                        Assgn.Work = v_Work
                                    End If
                                End If
                            Next Assgn
                            'Re-apply original Task Type
                            Tsk.Type = v_TaskType
                        End If
                    End If
                Next Tsk
            End If
        End Sub