Quantcast
Channel: blog.atwork.at
Viewing all articles
Browse latest Browse all 1118

Project: Kalenderausnahmen exportieren / Export Calendar Exceptions

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

Viewing all articles
Browse latest Browse all 1118

Latest Images