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
Source: https://blog.atwork.at/post/Project-Kalenderausnahmen-exportieren-Export-Calendar-Exceptions