Enable rotating biweekly calendar schedule in Projects 2007 VBA - vba

Question

Based on the code by Rachel Hettinger.
I would like to modify this code in such a way that I have a calendar 2 weeks of 6am to 2:30pm Monday through Friday then Monday through Thursday from 2pm to 12:30am (ending Friday morning). I require it to be this way as my human resources rotate between two weeks days and two weeks nights. I have gotten the calendar to the point that it will apply the two different shift starting times, but not the two different durations, or the non-working Friday afternoon.
I tried an IIF, and tired to have it accomplish this based on the cycle number, but I don't think I have my setup correct. I tried putting the code to select each shift as their own sub, but I'm a beginner and don't think I did it correctly.
Any assistance is appreciated.
'# is the original code
'##add an If qualifier to select between two different set conditions?
' Set e = Iif(CycleNum = "1" Or "2", c.Exceptions.Add(Type:=pjDaily _
' , Start:=CyclesStart + (i - 1) * 7 _
' , Occurrences:=5 _
' , Name:=ExceptionName & CycleNum),
' c.Exceptions.Add(Type:=pjDaily _
' , Start:=CyclesStart + (i - 1) * 7 _
' , Occurrences:=5 _
' , Name:=ExceptionName & CycleNum))
'# Set e = c.Exceptions.Add(Type:=pjDaily _
'# , Start:=CyclesStart + (i - 1) * 7 _
'# , Occurrences:=5 _
'# , Name:=ExceptionName & CycleNum)
'# If Err.Number = 0 Then
'# e.Shift1.Start = StartTime
'# e.Shift1.Finish = StartTime + #8:30:00 AM# '-=adjust length of each shift, #X = hours=-
Else
'switch to day-by-day to not overwrite holidays inherited from the Standard calendar
Dim d As Long
For d = 1 To 5
Set e = c.Exceptions.Add(Type:=pjDaily _
, Start:=CyclesStart + (i - 1) * 7 + d - 1 _
, Occurrences:=1 _
, Name:=ExceptionName & CycleNum & " day " & d)
e.Shift1.Start = StartTime
e.Shift1.Finish = StartTime + #6:00:00 AM#
Next d
End If
On Error GoTo 0
Next i
Full Code:
Sub CreateRotatingCalendar()
'ORIGINAL AUTHOR: Rachel Hettinger
' Create a calendar with a cycle of 4 rotating weekly schedules by utilizing the calendar exceptions.
Const CalName As String = "Rotating Shift Alpha" 'name of calendar
Const ExceptionName As String = "Cycle "
'set number of weeks and start times per calendar
Const Week1Start As Date = #6:00:00 AM#
Const Week2Start As Date = #6:00:00 AM#
Const Week3Start As Date = #2:00:00 PM#
Const Week4Start As Date = #2:00:00 PM#
'Set Calendar start and end dates
Const CyclesStart As Date = #8/1/2022# ' must be a Monday
Const CyclesEnd As Date = #8/8/2032# '
' create calendar, but ignore errors in case calendar already exists
On Error Resume Next
BaseCalendarCreate Name:=CalName, FromName:="Standard"
On Error GoTo 0
Dim c As Calendar
Set c = ActiveProject.BaseCalendars(CalName)
' in case this routine is run again to update the rotating calendar, delete exceptions related to the rotation (and leave holidays)
Dim e As Exception
For Each e In c.Exceptions
If e.Name Like ExceptionName & "*" Then
e.Delete
End If
Next e
' remove other shifts and set shift hours
Dim wd As PjWeekday
For wd = pjMonday To pjFriday
c.WeekDays(wd).Shift1.Start = #6:00:00 AM#
c.WeekDays(wd).Shift1.Finish = #2:30:00 PM#
c.WeekDays(wd).Shift2.Start = #2:00:00 PM#
c.WeekDays(wd).Shift2.Finish = #12:30:00 AM#
c.WeekDays(wd).Shift3.Clear
c.WeekDays(wd).Shift4.Clear
c.WeekDays(wd).Shift5.Clear
Next wd
' create the exceptions week by week
Dim NumWeeks As Long
NumWeeks = (CyclesEnd - CyclesStart) \ 7
Dim i As Long
Dim CycleNum As String
Dim StartTime As Date
For i = 1 To NumWeeks + 1
Select Case i Mod 4
Case Is = 1: StartTime = Week1Start: CycleNum = "1"
Case Is = 2: StartTime = Week2Start: CycleNum = "2"
Case Is = 3: StartTime = Week3Start: CycleNum = "3"
Case Is = 0: StartTime = Week4Start: CycleNum = "4"
Case Else
End Select
On Error Resume Next
'##add an If qualifier to select between two different set conditions?
' Set e = Iif(CycleNum = "1" Or "2", c.Exceptions.Add(Type:=pjDaily _
' , Start:=CyclesStart + (i - 1) * 7 _
' , Occurrences:=5 _
' , Name:=ExceptionName & CycleNum),
' c.Exceptions.Add(Type:=pjDaily _
' , Start:=CyclesStart + (i - 1) * 7 _
' , Occurrences:=5 _
' , Name:=ExceptionName & CycleNum))
'# Set e = c.Exceptions.Add(Type:=pjDaily _
'# , Start:=CyclesStart + (i - 1) * 7 _
'# , Occurrences:=5 _
'# , Name:=ExceptionName & CycleNum)
'# If Err.Number = 0 Then
'# e.Shift1.Start = StartTime
'# e.Shift1.Finish = StartTime + #8:30:00 AM# '-=adjust length of each shift, #X = hours=-
Else
'switch to day-by-day to not overwrite holidays inherited from the Standard calendar
Dim d As Long
For d = 1 To 5
Set e = c.Exceptions.Add(Type:=pjDaily _
, Start:=CyclesStart + (i - 1) * 7 + d - 1 _
, Occurrences:=1 _
, Name:=ExceptionName & CycleNum & " day " & d)
e.Shift1.Start = StartTime
e.Shift1.Finish = StartTime + #6:00:00 AM#
Next d
End If
On Error GoTo 0
Next i
End Sub
My two added non-functional subs
'# Set Parameters for Shift 1
Sub Day_Shift()
Set e = c.Exceptions.Add(Type:=pjDaily _
, Start:=CyclesStart + (i - 1) * 7 _
, Occurrences:=5 _
, Name:=ExceptionName & CycleNum)
If Err.Number = 0 Then
e.Shift1.Start = StartTime
e.Shift1.Finish = StartTime + #8:30:00 AM# '-=adjust length of each shift, #X = hours=-
Else
'switch to day-by-day to not overwrite holidays inherited from the Standard calendar
Dim d As Long
For d = 1 To 5
Set e = c.Exceptions.Add(Type:=pjDaily _
, Start:=CyclesStart + (i - 1) * 7 + d - 1 _
, Occurrences:=1 _
, Name:=ExceptionName & CycleNum & " day " & d)
e.Shift1.Start = StartTime
e.Shift1.Finish = StartTime + #6:00:00 AM#
Next d
End If
End Sub
'# Set Parameters for Shift 2
'name
Sub Night_Shift()
'Start day per cycle, how many per week, and name
Set e = c.Exceptions.Add(Type:=pjDaily _
, Start:=CyclesStart + (i - 1) * 7 _
, Occurrences:=4 _
, Name:=ExceptionName & CycleNum)
If Err.Number = 0 Then
e.Shift2.Start = StartTime
e.Shift2.Finish = StartTime + #10:30:00 AM# '-=adjust length of each shift, #X = hours=-
Else
'switch to day-by-day to not overwrite holidays inherited from the Standard calendar
Dim d As Long
For d = 1 To 5
Set e = c.Exceptions.Add(Type:=pjDaily _
, Start:=CyclesStart + (i - 1) * 7 + d - 1 _
, Occurrences:=1 _
, Name:=ExceptionName & CycleNum & " day " & d)
e.Shift1.Start = StartTime
e.Shift1.Finish = StartTime + #6:00:00 AM#
Next d
End If
End Sub

Answer 1

In this case only one set of exceptions is needed--for the night shifts. However, since those shifts run across midnight the shift needs to be split into 2 parts: 2:00 PM - midnight and midnight - 12:30 AM. This results in the need for 3 exceptions for each of the night shift weeks:
Monday 2:00 PM - 12:00 AM
Tue-Thu 12:00 AM - 12:30 AM and 2:00 PM - 12:00 AM
Friday 12:00 AM - 12:30 AM
Here is updated code that does this:
Sub CreateRotatingCalendar()
' Create a calendar with a cycle of 4 rotating weekly schedules by utilizing the calendar exceptions.
Const CalName As String = "Rotating Shift Alpha" 'name of calendar
Const ExceptionName As String = "Nights "
' Set Calendar start and end dates
Const CyclesStart As Date = #8/1/2022# ' must be a Monday
Const CyclesEnd As Date = #8/8/2032#
' create calendar, but ignore errors in case calendar already exists
On Error Resume Next
BaseCalendarCreate Name:=CalName, FromName:="Standard"
On Error GoTo 0
Dim c As Calendar
Set c = ActiveProject.BaseCalendars(CalName)
' in case this routine is run again to update the rotating calendar, delete exceptions related to the rotation (and leave holidays)
Dim e As Exception
For Each e In c.Exceptions
If e.Name Like ExceptionName & "*" Then
e.Delete
End If
Next e
' remove other shifts and set shift hours
Dim wd As PjWeekday
For wd = pjMonday To pjFriday
c.WeekDays(wd).Shift1.Start = #6:00:00 AM#
c.WeekDays(wd).Shift1.Finish = #2:30:00 PM#
c.WeekDays(wd).Shift2.Clear
c.WeekDays(wd).Shift3.Clear
c.WeekDays(wd).Shift4.Clear
c.WeekDays(wd).Shift5.Clear
Next wd
' create the exceptions week by week
Dim NumWeeks As Long
NumWeeks = (CyclesEnd - CyclesStart) \ 7
Dim WeekNum As Long
For WeekNum = 1 To NumWeeks + 1
If WeekNum Mod 4 = 3 Or WeekNum Mod 4 = 0 Then
' create exceptions for the night shift
On Error Resume Next
Set e = c.Exceptions.Add(Type:=pjDaily _
, Start:=CyclesStart + (WeekNum - 1) * 7 _
, Occurrences:=1 _
, Name:=ExceptionName & " Monday")
e.Shift1.Start = #2:00:00 PM#
e.Shift1.Finish = #12:00:00 AM#
Set e = c.Exceptions.Add(Type:=pjDaily _
, Start:=CyclesStart + (WeekNum - 1) * 7 + 1 _
, Occurrences:=3 _
, Name:=ExceptionName & " Tu-Th")
e.Shift1.Start = #12:00:00 AM#
e.Shift1.Finish = #12:30:00 AM#
e.Shift2.Start = #2:00:00 PM#
e.Shift2.Finish = #12:00:00 AM#
Set e = c.Exceptions.Add(Type:=pjDaily _
, Start:=CyclesStart + (WeekNum - 1) * 7 + 4 _
, Occurrences:=1 _
, Name:=ExceptionName & " Friday")
e.Shift1.Start = #12:00:00 AM#
e.Shift1.Finish = #12:30:00 AM#
End If
On Error GoTo 0
Next WeekNum
End Sub
Note that since the working hours per week switches between 8.5 hours and 10.5 hours, scheduling should be done in hours rather than days. Review the calendar options for the project and change as needed (File: Options: Schedule)