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