View Full Version : Determining the working days
Aussiebear
01-31-2010, 09:02 PM
I was wondering if anyone has been able to combine a calendar control with the ability to automark working days depending on the roster required?
For example I need to compare the effects of a 4 on 4 off roster against variants using 5 and 7 day rosters. A user could enter a start of roster date and indicate if it was day or night shift.
Once this section is completed, I'llbe using Excel to complete costings per roster determined?
Bob Phillips
02-01-2010, 02:24 AM
I am sure it can be done with conditional formatting, but a simple, hammer macro approach seems easier
Public Function SetRota()
Const CI_ROTA_DAY As Long = 6
Const CI_ROTA_NIGHT As Long = 16
Const CI_ROTA_OFF As Long = xlColorIndexNone
Dim mpDayRota As Boolean
Dim mpStartDate As Date
Dim mpFirstCol As Long
Dim mpRota As Long
Dim mpNightOn As Long
Dim mpDayOn As Long
Dim mpAllOff As Long
Dim i As Long, j As Long, k As Long
With ActiveSheet
mpStartDate = .Range("AI3").Value2
mpRota = .Range("AI4").Value2
mpFirstCol = Day(mpStartDate) + 1
mpDayOn = mpRota + 1
mpNightOn = 1
mpAllOff = mpRota + 1
mpdatarota = False
For i = 2 To 25
For j = mpFirstCol To 32
If .Cells(i, j).Value2 = "" Then
j = 32
Else
Select Case True
Case mpDayOn > mpRota And mpAllOff > mpRota
.Cells(i, j).Interior.ColorIndex = CI_ROTA_NIGHT
mpNightOn = mpNightOn + 1
If mpNightOn > mpRota Then
mpAllOff = 1
End If
Case mpNightOn > mpRota And mpAllOff > mpRota
.Cells(i, j).Interior.ColorIndex = CI_ROTA_DAY
mpDayOn = mpDayOn + 1
If mpDayOn > mpRota Then
mpAllOff = 1
End If
Case mpNightOn > mpRota And mpDayOn > mpRota
.Cells(i, j).Interior.ColorIndex = CI_ROTA_OFF
mpAllOff = mpAllOff + 1
If mpAllOff > mpRota Then
mpDayRota = Not mpDayRota
If mpDayRota Then
mpDayOn = 1
Else
mpNightOn = 1
End If
End If
End Select
End If
Next j
mpFirstCol = 2
Next i
End With
End Function
Bob Phillips
02-01-2010, 02:25 AM
BTW, don't you need a cell to say whether it starts on a day or night rota.
Aussiebear
02-01-2010, 05:47 AM
Yes I do Bob.
The following code inserts a new worksheet,with a 12 month calendar placed in the range A1:U28. Its a start, even though the layout needs some changes. Thinking that possibly needs to double the Heading so that the days of the week can be moved to the row just below the Month Heading.
Sub CreateCalendar()
Dim lMonth As Long
Dim strMonth As String
Dim rStart As Range
Dim strAddress As String
Dim rCell As Range
Dim lDays As Long
Dim dDate As Date
'Add new sheet and format
Worksheets.Add
ActiveWindow.DisplayGridlines = False
With Cells
.ColumnWidth = 6#
.Font.Size = 8
End With
'Create the Month headings
For lMonth = 1 To 4
Select Case lMonth
Case 1
strMonth = "January"
Set rStart = Range("A1")
Case 2
strMonth = "April"
Set rStart = Range("A8")
Case 3
strMonth = "July"
Set rStart = Range("A15")
Case 4
strMonth = "October"
Set rStart = Range("A22")
End Select
'Merge, AutoFill and align months
With rStart
.Value = strMonth
.HorizontalAlignment = xlCenter
.Interior.ColorIndex = 6
.Font.Bold = True
With .Range("A1:G1")
.Merge
.BorderAround LineStyle:=xlContinuous
End With
.Range("A1:G1").AutoFill Destination:=.Range("A1:U1")
End With
Next lMonth
'Pass ranges for months
For lMonth = 1 To 12
strAddress = Choose(lMonth, "A2:G7", "H2:N7", "O2:U7", _
"A9:G14", "H9:N14", "O9:U14", _
"A16:G21", "H16:N21", "O16:U21", _
"A23:G28", "H23:N28", "O23:U28")
lDays = 0
Range(strAddress).BorderAround LineStyle:=xlContinuous
'Add dates to month range and format
For Each rCell In Range(strAddress)
lDays = lDays + 1
dDate = DateSerial(Year(Date), lMonth, lDays)
If Month(dDate) = lMonth Then ' It's a valid date
With rCell
.Value = dDate
.NumberFormat = "ddd dd"
End With
End If
Next rCell
Next lMonth
'add con formatting
With Range("A1:U28")
.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=TODAY()"
.FormatConditions(1).Font.ColorIndex = 2
.FormatConditions(1).Interior.ColorIndex = 1
End With
End Sub
Once I understand the code, I'll work on the routine to mark off the actual rosters
Bob Phillips
02-01-2010, 06:59 AM
Is there a question there Ted, and how does it relate to the original question?
Aussiebear
02-01-2010, 02:57 PM
Its simply one method of building a calendar, that in time may be amended to look something more like the calendar control offered by Microsoft. Once I'm happy with the layout, I'll be trying to work out how to mark out the required days on days off
Bob Phillips
02-01-2010, 04:36 PM
How about this
Sub CreateCalendar()
Const CI_OUTWITH_DAY As Long = 15
Const CI_DAY_NAME As Long = 36
Const CI_MONTH_NAME As Long = 6
Const CI_FONT_TODAY As Long = 0
Const CI_FILL_TODAY As Long = 3
Const COLWIDTH_DAY As Long = 6
Const FONT_SIZE As Long = 8
Const FORMULA_OUTWITH As String = "=MONTH(<cell>)<><month>"
Dim lMonthRow As Long
Dim lMonthCol As Long
Dim lMonthWeek As Long
Dim FirstDate As Date
Dim i As Long
'Add new sheet and format
Worksheets.Add
ActiveWindow.DisplayGridlines = False
With Cells
.ColumnWidth = COLWIDTH_DAY
.Font.Size = FONT_SIZE
End With
'Create the Month headings
For lMonthRow = 1 To 4
With Cells((lMonthRow - 1) * 8 + 1, "A")
.Value = Format("01-" & (lMonthRow - 1) * 3 + 1, "mmmm")
.HorizontalAlignment = xlCenter
.Interior.ColorIndex = CI_MONTH_NAME
.Font.Bold = True
With .Resize(, 7)
.Merge
.BorderAround LineStyle:=xlContinuous
End With
.Resize(, 7).AutoFill Destination:=.Resize(, 21)
With .Offset(1, 0)
.Value = "Sun"
.AutoFill Destination:=.Resize(, 7)
With .Resize(, 7)
.HorizontalAlignment = xlCenter
.Interior.ColorIndex = CI_DAY_NAME
.Font.Bold = True
.BorderAround LineStyle:=xlContinuous
.Copy .Offset(, 7)
.Copy .Offset(, 14)
End With
End With
End With
Next lMonthRow
'Pass ranges for months
For lMonthRow = 1 To 4
For lMonthCol = 1 To 3
FirstDate = DateSerial(Year(Date), (lMonthRow - 1) * 3 + lMonthCol, 1)
FirstDate = FirstDate - (Weekday(FirstDate) - 2) - 1
With Cells((lMonthRow - 1) * 8 + 3, (lMonthCol - 1) * 7 + 1)
For lMonthWeek = 1 To 6
With .Offset(lMonthWeek - 1)
.Value2 = FirstDate + (lMonthWeek - 1) * 7
.Offset(0, 1).Value2 = FirstDate + (lMonthWeek - 1) * 7 + 1
.Resize(, 2).AutoFill Destination:=.Resize(, 7)
End With
Next lMonthWeek
With .Resize(6, 7)
.BorderAround LineStyle:=xlContinuous
.NumberFormat = "dd"
.HorizontalAlignment = xlCenter
.FormatConditions.Add Type:=xlExpression, _
Formula1:=Replace(Replace(FORMULA_OUTWITH, _
"<cell>", ActiveCell.Address(False, False)), _
"<month>", (lMonthRow - 1) * 3 + lMonthCol)
.FormatConditions(1).Font.ColorIndex = CI_OUTWITH_DAY
.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=TODAY()"
.FormatConditions(2).Font.ColorIndex = CI_FONT_TODAY
.FormatConditions(2).Interior.ColorIndex = CI_FILL_TODAY
End With
End With
Next lMonthCol
Next lMonthRow
End Sub
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.