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 tabulatorConst c_ListSeparator = vbTab'"True" to get all exceptions like half days, .... "False" to get only non working daysConst c_AllExceptions = TrueDim v_Cal As CalendarDim RC As CalendarDim Ex As ExceptionDim R As ResourceDim T As TaskDim P As ProjectDim v_D AsDateDim WHours AsDoubleDim ArrI AsIntegerDim i AsLongDim v_OutputFile AsString'Define output file v_OutputFile = Environ("USERPROFILE") & "\Desktop\CalendarExceptions.csv"ReDim ArrExeption(50000, 3)Set P = ActiveProjectSet v_Cal = P.Calendar ArrI = 0'Project CalendarsForEach v_Cal In P.BaseCalendarsForEach Ex In v_Cal.ExceptionsFor v_D = Ex.Start To Ex.Finish'Only exceptions during Project's durationIf 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 falseIf v_Cal.Period(v_D, v_D).Working = FalseOr c_AllExceptions = TrueThen WHours = 0If 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)EndIfEndIfEndIfEndIfEndIf 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 + 1EndIfEndIfNext v_DNext ExNext v_Cal'Resource CalendarsForEach R In P.ResourcesSet v_Cal = R.CalendarForEach Ex In v_Cal.ExceptionsFor v_D = Ex.Start To Ex.Finish'Only exceptions during Project's durationIf v_D >= P.ProjectSummaryTask.Start And v_D <= P.ProjectSummaryTask.Finish Then'only non working days if c_AllExceptions ist set to falseIf v_Cal.Period(v_D, v_D).Working = FalseOr c_AllExceptions = TrueThen WHours = 0If 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)EndIfEndIfEndIfEndIfEndIf 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 + 1EndIfEndIfNext v_DNext ExNext R'Set ArrI to exceptions count ArrI = ArrI - 1'Sort all exceptions by date, if there are anyIf ArrI >= 0 Then'RedimPreserve for multi dimensional array ArrExeption = ReDimPreserve(ArrExeption, ArrI, 3)'Sort by dateCall 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 #1Else MsgBox ("No Exceptions")EndIfEndSubPublicSub QuickSortArray(ByRef SortArray AsVariant, Optional lngMin AsLong = -1, Optional lngMax AsLong = -1, Optional lngColumn AsLong = 0)OnErrorResumeNext'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 inputsDim i AsLongDim j AsLongDim varMid AsVariantDim arrRowTemp AsVariantDim lngColTemp AsLongIf IsEmpty(SortArray) ThenExitSub End IfIf InStr(TypeName(SortArray), "()") < 1 Then'IsArray() is somewhat broken: Look for brackets in the type nameExitSub End IfIf lngMin = -1 Then lngMin = LBound(SortArray, 1)EndIfIf lngMax = -1 Then lngMax = UBound(SortArray, 1)EndIfIf lngMin >= lngMax Then' no sorting requiredExitSub 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 = lngMinElseIf IsEmpty(varMid) Then i = lngMax j = lngMinElseIf IsNull(varMid) Then i = lngMax j = lngMinElseIf varMid = ""Then i = lngMax j = lngMinElseIf VarType(varMid) = vbError Then i = lngMax j = lngMinElseIf VarType(varMid) > 17 Then i = lngMax j = lngMinEndIfWhile i <= jWhile SortArray(i, lngColumn) < varMid And i < lngMax i = i + 1WendWhile varMid < SortArray(j, lngColumn) And j > lngMin j = j - 1WendIf i <= j Then' Swap the rowsReDim 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 lngColTempErase arrRowTemp i = i + 1 j = j - 1 EndIfWendIf (lngMin < j) ThenCall QuickSortArray(SortArray, lngMin, j, lngColumn)If (i < lngMax) ThenCall QuickSortArray(SortArray, i, lngMax, lngColumn)EndSubPublicFunction 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 firstIf IsArray(aArrayToPreserve) Then'create new arrayReDim aPreservedArray(nNewFirstUBound, nNewLastUBound)'get old lBound/uBound nOldFirstUBound = UBound(aArrayToPreserve, 1) nOldLastUBound = UBound(aArrayToPreserve, 2)'loop through firstFor nFirst = LBound(aArrayToPreserve, 1) To nNewFirstUBoundFor nLast = LBound(aArrayToPreserve, 2) To nNewLastUBound'if its in range, then append to new array the same wayIf nOldFirstUBound >= nFirst And nOldLastUBound >= nLast Then aPreservedArray(nFirst, nLast) = aArrayToPreserve(nFirst, nLast)EndIfNextNext'return the array redimmedIf IsArray(aPreservedArray) Then ReDimPreserve = aPreservedArrayEndIfEndFunction