PDA

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