blog.atwork.at

news and infos about microsoft, technology, cloud and more

Project: Kalenderausnahmen exportieren / Export Calendar Exceptions

  1. Deutsch
  2. English
  3. Code

Deutsch

Häufig wird in Foren die Frage gestellt, wie Ausnahmen (Abwesenheiten oder abweichende Arbeitszeiten) exportiert werden können. Hier ist ein Makro bereitgestellt, das alle Kalenderausnahemn in eine Datei exportiert. Dabei werden alle Ausnahmen aller Projektkalender und aller Ressourcenkalender während der Projektlaufzeit berücksichtigt. Mit dem Setzen einer Konstanten zu beginn, können Sie definieren, ob nur arbeitsfreie Tage oder alle Ausnahmen exportiert werden sollen.

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

English

In forums there is often  the question how to export calendar exceptions (absences or deviating working hours). Here is a macro provided that exports all calendar exceptions to a file. All exceptions of all project calendars and all resource calendars are taken into account during the project period. By setting a constant at the beginning, you can define whether only non-working days or all exceptions should be exported.

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

Code

Sub GetAllCalendarExceptions()

'***********************************************************************************
'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.
'***********************************************************************************

' "," for Regional settings English, ";" for Regional Settings German, "|" other, vbTab for tabulator
Const c_ListSeparator = vbTab

'"True" to get all exceptions like half days, .... "False" to get only non working days
Const c_AllExceptions = True

Dim v_Cal As Calendar
Dim RC As Calendar
Dim Ex As Exception
Dim R As Resource
Dim T As Task
Dim P As Project
Dim v_D As Date
Dim WHours As Double
Dim ArrI As Integer
Dim i As Long

Dim v_OutputFile As String

'Define output file
v_OutputFile = Environ("USERPROFILE") & "\Desktop\CalendarExceptions.csv"

ReDim ArrExeption(50000, 3)

Set P = ActiveProject
Set v_Cal = P.Calendar
ArrI = 0

'Project Calendars
For Each v_Cal In P.BaseCalendars
    For Each Ex In v_Cal.Exceptions
        For v_D = Ex.Start To Ex.Finish
            'Only exceptions during Project's duration
            If v_D >= DateSerial(Year(P.ProjectSummaryTask.Start), _
                                 Month(P.ProjectSummaryTask.Start), _
                                 Day(P.ProjectSummaryTask.Start)) _
               And v_D <= DateSerial(Year(P.ProjectSummaryTask.Finish), _
                                     Month(P.ProjectSummaryTask.Finish), _
                                     Day(P.ProjectSummaryTask.Finish)) _
               Then
                'only non working days if c_AllExceptions ist set to false
                If v_Cal.Period(v_D, v_D).Working = False Or c_AllExceptions = True Then
                    WHours = 0
                    If Ex.Shift1.Start <> 0 Then
                        WHours = DateDiff("h", Ex.Shift1.Start, Ex.Shift1.Finish)
                        If Ex.Shift2.Start <> 0 Then
                            WHours = WHours _
                                     + DateDiff("h", Ex.Shift2.Start, Ex.Shift2.Finish)
                            If Ex.Shift3.Start <> 0 Then
                                WHours = WHours _
                                         + DateDiff("h", Ex.Shift3.Start, Ex.Shift3.Finish)
                                If Ex.Shift4.Start <> 0 Then
                                    WHours = WHours _
                                             + DateDiff("h", Ex.Shift4.Start, Ex.Shift4.Finish)
                                    If Ex.Shift5.Start <> 0 Then
                                        WHours = WHours _
                                                 + DateDiff("h", Ex.Shift5.Start, Ex.Shift5.Finish)
                                    End If
                                End If
                            End If
                        End If
                    End If
                    ArrExeption(ArrI, 0) = v_D          'Date
                    ArrExeption(ArrI, 1) = Ex.Name      'Exception Name
                    ArrExeption(ArrI, 2) = v_Cal.Name   'Calendar Name
                    ArrExeption(ArrI, 3) = WHours       'Working hours
                    ArrI = ArrI + 1
                End If
            End If
        Next v_D
    Next Ex
Next v_Cal

'Resource Calendars
For Each R In P.Resources
Set v_Cal = R.Calendar
    For Each Ex In v_Cal.Exceptions
        For v_D = Ex.Start To Ex.Finish
            'Only exceptions during Project's duration
            If v_D >= P.ProjectSummaryTask.Start And v_D <= P.ProjectSummaryTask.Finish Then
                'only non working days if c_AllExceptions ist set to false
                If v_Cal.Period(v_D, v_D).Working = False Or c_AllExceptions = True Then
                    WHours = 0
                    If Ex.Shift1.Start <> 0 Then
                        WHours = DateDiff("h", Ex.Shift1.Start, Ex.Shift1.Finish)
                        If Ex.Shift2.Start <> 0 Then
                            WHours = WHours + DateDiff("h", Ex.Shift2.Start, Ex.Shift2.Finish)
                            If Ex.Shift3.Start <> 0 Then
                                WHours = WHours + DateDiff("h", Ex.Shift3.Start, Ex.Shift3.Finish)
                                If Ex.Shift4.Start <> 0 Then
                                    WHours = WHours + DateDiff("h", Ex.Shift4.Start, Ex.Shift4.Finish)
                                    If Ex.Shift5.Start <> 0 Then
                                        WHours = WHours + DateDiff("h", Ex.Shift5.Start, Ex.Shift5.Finish)
                                    End If
                                End If
                            End If
                        End If
                    End If
                    ArrExeption(ArrI, 0) = v_D          'Date
                    ArrExeption(ArrI, 1) = Ex.Name      'Exception Name
                    ArrExeption(ArrI, 2) = v_Cal.Name   'Calendar Name
                    ArrExeption(ArrI, 3) = WHours       'Working hours
                    ArrI = ArrI + 1
                End If
            End If
        Next v_D
    Next Ex

Next R

'Set ArrI to exceptions count
ArrI = ArrI - 1

'Sort all exceptions by date, if there are any
If ArrI >= 0 Then
    'RedimPreserve for multi dimensional array
    ArrExeption = ReDimPreserve(ArrExeption, ArrI, 3)
    
    'Sort by date
    Call QuickSortArray(ArrExeption, , , 0)
    
    
    'Write all exception to file
    Open v_OutputFile For Output As #1
    Close #1
    Open v_OutputFile For Append As #1
    Print #1, "Date" _
             & c_ListSeparator _
             & "Exception" _
             & c_ListSeparator _
             & "Calendar" _
             & c_ListSeparator _
             & "Working Hours"
    For i = 0 To ArrI
        Print #1, ArrExeption(i, 0) _
                & c_ListSeparator _
                & ArrExeption(i, 1) _
                & c_ListSeparator _
                & ArrExeption(i, 2) _
                & c_ListSeparator _
                & ArrExeption(i, 3)
    Next i
    Close #1
Else
    MsgBox ("No Exceptions")
End If

End Sub


Public Sub QuickSortArray(ByRef SortArray As Variant, Optional lngMin As Long = -1, Optional lngMax As Long = -1, Optional lngColumn As Long = 0)
    On Error Resume Next
'Kudos to Jim Rech and Nigel Heffernan at https://stackoverflow.com/questions/4873182/sorting-a-multidimensionnal-array-in-vba/5104206#5104206

    'Sort a 2-Dimensional array

    ' SampleUsage: sort arrData by the contents of column 3
    '
    '   QuickSortArray arrData, , , 3

    '
    'Posted by Jim Rech 10/20/98 Excel.Programming

    'Modifications, Nigel Heffernan:

    '       ' Escape failed comparison with empty variant
    '       ' Defensive coding: check inputs

    Dim i As Long
    Dim j As Long
    Dim varMid As Variant
    Dim arrRowTemp As Variant
    Dim lngColTemp As Long

    If IsEmpty(SortArray) Then
        Exit Sub
    End If
    If InStr(TypeName(SortArray), "()") < 1 Then  'IsArray() is somewhat broken: Look for brackets in the type name
        Exit Sub
    End If
    If lngMin = -1 Then
        lngMin = LBound(SortArray, 1)
    End If
    If lngMax = -1 Then
        lngMax = UBound(SortArray, 1)
    End If
    If lngMin >= lngMax Then    ' no sorting required
        Exit Sub
    End If

    i = lngMin
    j = lngMax

    varMid = Empty
    varMid = SortArray((lngMin + lngMax) \ 2, lngColumn)

    ' We  send 'Empty' and invalid data items to the end of the list:
    If IsObject(varMid) Then  ' note that we don't check isObject(SortArray(n)) - varMid *might* pick up a valid default member or property
        i = lngMax
        j = lngMin
    ElseIf IsEmpty(varMid) Then
        i = lngMax
        j = lngMin
    ElseIf IsNull(varMid) Then
        i = lngMax
        j = lngMin
    ElseIf varMid = "" Then
        i = lngMax
        j = lngMin
    ElseIf VarType(varMid) = vbError Then
        i = lngMax
        j = lngMin
    ElseIf VarType(varMid) > 17 Then
        i = lngMax
        j = lngMin
    End If

    While i <= j
        While SortArray(i, lngColumn) < varMid And i < lngMax
            i = i + 1
        Wend
        While varMid < SortArray(j, lngColumn) And j > lngMin
            j = j - 1
        Wend

        If i <= j Then
            ' Swap the rows
            ReDim arrRowTemp(LBound(SortArray, 2) To UBound(SortArray, 2))
            For lngColTemp = LBound(SortArray, 2) To UBound(SortArray, 2)
                arrRowTemp(lngColTemp) = SortArray(i, lngColTemp)
                SortArray(i, lngColTemp) = SortArray(j, lngColTemp)
                SortArray(j, lngColTemp) = arrRowTemp(lngColTemp)
            Next lngColTemp
            Erase arrRowTemp

            i = i + 1
            j = j - 1
        End If
    Wend

    If (lngMin < j) Then Call QuickSortArray(SortArray, lngMin, j, lngColumn)
    If (i < lngMax) Then Call QuickSortArray(SortArray, i, lngMax, lngColumn)

End Sub
Public Function ReDimPreserve(aArrayToPreserve, nNewFirstUBound, nNewLastUBound)
'Kudos to Control Freak at https://stackoverflow.com/questions/13183775/excel-vba-how-to-redim-a-2d-array/21014121#21014121
    ReDimPreserve = False
    'check if its in array first
    If IsArray(aArrayToPreserve) Then
        'create new array
        ReDim aPreservedArray(nNewFirstUBound, nNewLastUBound)
        'get old lBound/uBound
        nOldFirstUBound = UBound(aArrayToPreserve, 1)
        nOldLastUBound = UBound(aArrayToPreserve, 2)
        'loop through first
        For nFirst = LBound(aArrayToPreserve, 1) To nNewFirstUBound
            For nLast = LBound(aArrayToPreserve, 2) To nNewLastUBound
                'if its in range, then append to new array the same way
                If nOldFirstUBound >= nFirst And nOldLastUBound >= nLast Then
                    aPreservedArray(nFirst, nLast) = aArrayToPreserve(nFirst, nLast)
                End If
            Next
        Next
        'return the array redimmed
        If IsArray(aPreservedArray) Then ReDimPreserve = aPreservedArray
    End If
End Function
Loading