Access VBA for 4 on 4 off leave calendar

I am a firefighter and work a 4 days on 4 days of roster. I have found a great Access database for planning and managing leave. Only problem is it compiles the leave data for staff based on monday to friday - "If Weekday(MyDate, vbMonday) - 1 < 5" in below code. What code could I substitute here to select days on a 4 on 4 off basis?

For d = 1 To 31
If d > LastDayOfMonth Then
Temp = "-"
MyDate = DateSerial(2000 + MyYear, m, d)
    If Weekday(MyDate, vbMonday) - 1 < 5 Then
    Temp = "."
    Do While Not LData.EOF
        If LUsers!uinits = LData!LInits Then
            If MyDate >= LData!LDateFrom And MyDate <= LData!LDateTo Then
            Temp = LData!LType
            Exit Do
            End If
        End If
    Temp = "."
    End If
End If

Open in new window

Who is Participating?
You need to define a start day, so say your first work day in a week was 2010-10-15.

So what you need to do is figure the number of days since then, and divide by 4.  If the number is even, it is a day you work, if odd, it is a day you have off.

Use this function
If IsWorkingDay(MyDate) Then

in place of
If Weekday(MyDate, vbMonday) - 1 < 5 Then

Private Const StartingDate as Date = #10-15-2010#

Public Function IsWorkingDay(DateToCheck As Date) As Boolean
     If (DateDiff("d",StartingDate,DateToCheck) \ 4) Mod 2 = 0 Then
          IsWorkingDay = True
          IsWorkingDay = False
     End If
End Function

Open in new window


 If Weekday(MyDate, vbMonday) - 1 < 5 Then

 If Weekday(MyDate, vbMonday) - 1 < 4 Then

Then it will be from Monday to Thursday I think.

Best Regards Tompa
Gustav BrockCIOCommented:
You need something like that for the Swedish 3-3-System and its numbering method for the 3-days-work and 3-days-off periods crossing the normal 7-day week boundaries as well as calendar years.

Thus, first of all, a fixed date that marks the beginning of the sequences.
Then, modification of the code below from a 3-3 sequence to a 4-4 sequence. Should be easy, but if you need assistance, please tell.

Option Compare Database
Option Explicit

' 3-3-System methods.
' 2000-01-22. Cactus Data ApS, CPH.
  ' First date of the 3-3-system is by definition Monday 1998-04-06.
  Private Const pdatThreeThreeCyclusPrimo     As Date = #4/6/1998#
  ' Length of the 3-3-system cyclus by definition.
  Private Const plngThreeThreeCyclusLength    As Long = 6
  ' Value of the 3-3-system cyclus' first day, numeric: 1.
  Private Const plngThreeThreeCyclusFirstNum  As Long = 1
  ' Value of the 3-3-system cyclus' first day, alpha: "A".
  Private Const plngThreeThreeCyclusFirstChr  As Long = &H41

Public Function ThreeThreeCyclusDay( _
  ByVal datDate As Date, _
  Optional booChar As Boolean) As Long

  Dim lngThreeThreeCyclusDay          As Long
  Dim lngThreeThreeCyclusDayFirstVal  As Long
  If booChar = True Then
    lngThreeThreeCyclusDayFirstVal = plngThreeThreeCyclusFirstChr
    lngThreeThreeCyclusDayFirstVal = plngThreeThreeCyclusFirstNum
  End If
  lngThreeThreeCyclusDay = DateDiff("d", pdatThreeThreeCyclusPrimo, datDate) Mod plngThreeThreeCyclusLength
  ThreeThreeCyclusDay = lngThreeThreeCyclusDayFirstVal + lngThreeThreeCyclusDay
End Function

Public Function ThreeThreeCyclusDayChr( _
  ByVal datDate As Date) As String
  Dim strThreeThreeCyclusDayChr As String * 1
  strThreeThreeCyclusDayChr = Chr(ThreeThreeCyclusDay(datDate, True))
  ThreeThreeCyclusDayChr = strThreeThreeCyclusDayChr

End Function

Open in new window

Gustav BrockCIOCommented:
The 3-3-system® or ThreeThree® is described here:

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.