I updated my code. The code below starts by asigning holidays only.
See if this looks fair. I setup a queue to select employee for each
shift. I assigned a point value depending on the type of day/shift the
employee is working. so I start out by going through the entire
calendar year and each holiday I choose the employees to work wih the
lowest score which I get from the queue. The scores in the queue can be
changed if the assinments don't look correct.
Job duties may be assigned random based on the people working. I'm also
thinking if a person works a holiday on either Saturday or Sunday they
should work both weekend dates.
Let me know what your holidays are so I'm woking with the same schedule
you have. My next task would be to assign weekends. I would check if
he person is working a holiday in the middle of the week and not assign
the person to work either the weekend before or the weekend after the
holiday.
Is it better for a person to have both Saturday and Sunday off together
or have a person work either Saturday or Sunday.
I would then assign the 7 days off for each person. Is the 7 days off
for the month?
Look at the code and se if there is any problems with my logic for
assinments. Based on my scoring system I will assign night before day
shift base on the lowest score in the queue. Then fill in the day
schedule with the remaining workers.
VBA Code:
--------------------
Const NumberOfStaff = 10
Const FirstShiftRow = 6
Const SkipRows = 3
Const WorkDayValue = 1
Const PMBonus = 0.2
Const WeekendBonus = 0.5
Const HolidayBonus = 1
Enum WorkType
NotScheduled
Work
Off
WorkAM
WorkPM
End Enum
Type CalendarDay
AM As Integer
PM As Integer
Holiday As Boolean
BillDate As Boolean
Employee(NumberOfStaff) As WorkType
End Type
Type EmployeeScore
Number As Integer
Score As Single
End Type
'366 days to include leap years
Dim WorkYear(0 To 365) As CalendarDay
Dim Queue(0 To (NumberOfStaff - 1)) As EmployeeScore
Sub MakeSchedule()
MyYearStr = InputBox("Enter Year : ")
MyYear = Val(MyYearStr)
'Delete All sheets except Holiday
Application.DisplayAlerts = False
For ShtCount = Sheets.Count To 1 Step -1
If Sheets(ShtCount).Name <> "Holidays" Then
Sheets(ShtCount).Delete
End If
Next ShtCount
Application.DisplayAlerts = True
'initialize employee queue
For EmployeeCount = 0 To (NumberOfStaff - 1)
Queue(EmployeeCount).Number = EmployeeCount + 1
Queue(EmployeeCount).Score = 0
Next EmployeeCount
Call MakeCalendar(MyYear)
Call AssignHolidays(MyYear)
Call OutputCalendar(MyYear)
End Sub
Sub AssignHolidays(MyYear)
FirstDay = DateSerial(MyYear, 1, 1)
LastDay = DateSerial(MyYear + 1, 1, 1) - 1
DayCount = FirstDay
DayOfYear = 0
Do While DayCount <= LastDay
If WorkYear(DayOfYear).Holiday = True Then
Call SortQueue
DayScore = WorkDayValue + HolidayBonus
If Weekday(DayCount, vbSunday) = vbSaturday Or _
Weekday(DayCount, vbSunday) = vbSunday Then
DayScore = DayScore + WeekendBonus
End If
QueCount = 0
'assign employee to work based on order in queue
'Assign AM work
For EmployeeCount = 1 To WorkYear(DayOfYear).AM
EmployeeNumber = Queue(QueCount).Number
'add the day value to employee score
Queue(QueCount).Score = Queue(QueCount).Score + _
DayScore
WorkYear(DayOfYear).Employee(EmployeeNumber) = WorkAM
QueCount = QueCount + 1
Next EmployeeCount
'Assign PM work
For EmployeeCount = 1 To WorkYear(DayOfYear).AM
EmployeeNumber = Queue(QueCount).Number
'add the day value to employee score
Queue(QueCount).Score = Queue(QueCount).Score + _
DayScore + PMBonus
WorkYear(DayOfYear).Employee(EmployeeNumber) = WorkPM
QueCount = QueCount + 1
Next EmployeeCount
End If
DayOfYear = DayOfYear + 1
DayCount = DayCount + 1
Loop
End Sub
Sub SortQueue()
For i = 0 To (NumberOfStaff - 2)
For j = (i + 1) To (NumberOfStaff - 1)
If Queue(i).Score > Queue(j).Score Then
'swap employees
temp = Queue(i).Number
Queue(i).Number = Queue(j).Number
Queue(j).Number = temp
temp = Queue(i).Score
Queue(i).Score = Queue(j).Score
Queue(j).Score = temp
End If
Next j
Next i
End Sub
Sub MakeCalendar(MyYear)
'Get holiday range
With Sheets("Holidays")
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
Set HolidayRange = .Range("A2:A" & LastRow)
End With
FirstDay = DateSerial(MyYear, 1, 1)
LastDay = DateSerial(MyYear + 1, 1, 1) - 1
DayCount = FirstDay
DayOfYear = 0
Do While DayCount <= LastDay
'Get LastDay of the Month as a date
'the last day of the month is the day before
'the 1st day of the next month
LastDayofMonth = DateSerial(MyYear, _
Month(DayCount) + 1, 1) - 1
'check if Bill Date
Select Case Day(DayCount)
Case 5, 7, 11, 14, 17, 21, 25, Day(LastDayofMonth)
BillDate = True
Case Else
BillDate = False
End Select
WorkYear(DayOfYear).BillDate = BillDate
'check if date is a holiday
Holiday = False
For Each MyHoliday In HolidayRange
If DayCount = MyHoliday Then
Holiday = True
Exit For
End If
Next MyHoliday
WorkYear(DayOfYear).Holiday = Holiday
If Weekday(DayCount, vbSunday) = vbSaturday Or _
Weekday(DayCount, vbSunday) = vbSunday Or _
Holiday = True Then
If BillDate = True Then
AM_Needed = 2
PM_Needed = 2
Else
AM_Needed = 2
PM_Needed = 1
End If
Else
If BillDate = True Then
AM_Needed = 6
PM_Needed = 3
Else
If Weekday(DayCount, vbSunday) = vbFriday Then
AM_Needed = 5
PM_Needed = 3
Else
AM_Needed = 6
PM_Needed = 2
End If
End If
End If
WorkYear(DayOfYear).AM = AM_Needed
WorkYear(DayOfYear).PM = PM_Needed
For EmployeeCount = 0 To (NumberOfStaff - 1)
WorkYear(DayOfYear).Employee(EmployeeCount) = NotScheduled
Next EmployeeCount
DayOfYear = DayOfYear + 1
DayCount = DayCount + 1
Loop
End Sub
Sub OutputCalendar(MyYear)
FirstDay = DateSerial(MyYear, 1, 1)
LastDay = DateSerial(MyYear + 1, 1, 1) - 1
CurrentMonth = 0
DayOfYear = 0
DayCount = FirstDay
Do While DayCount <= LastDay
If Month(DayCount) <> CurrentMonth Then
'if not first month autformat columns
If CurrentMonth <> 0 Then
MonthSht.Columns.AutoFit
End If
'add newsheet
'put name of month on worksheet tab
Set MonthSht = Sheets.Add(after:=Sheets(Sheets.Count))
CurrentMonth = CurrentMonth + 1
With MonthSht
.Name = MonthName(CurrentMonth, abbreviate:=True)
.Range("A3") = "Bill Date"
.Range("A4") = "Holiday"
.Range("A" & FirstShiftRow) = "First Shift Number Needed"
.Range("A" & FirstShiftRow + 1) = "Second Shift Number Needed"
'Put emplyee number in row header
For EmployeeCount = 1 To NumberOfStaff
.Range("A" & _
(FirstShiftRow + EmployeeCount + SkipRows)) = _
"Employee " & EmployeeCount
Next EmployeeCount
End With
ColCount = 2
End If
With MonthSht
'put days of month on column Header
.Cells(1, ColCount) = Day(DayCount)
.Cells(2, ColCount) = Format(DayCount, "DDD")
.Cells(3, ColCount) = WorkYear(DayOfYear).BillDate
.Cells(4, ColCount) = WorkYear(DayOfYear).Holiday
.Cells(FirstShiftRow, ColCount) = WorkYear(DayOfYear).AM
.Cells(FirstShiftRow + 1, ColCount) = WorkYear(DayOfYear).PM
For EmployeeCount = 0 To (NumberOfStaff - 1)
Select Case WorkYear(DayOfYear).Employee(EmployeeCount)
Case NotScheduled
WorkTypeStr = ""
Case Work
WorkTypeStr = "Work"
Case Off
WorkTypeStr = "Off"
Case WorkAM
WorkTypeStr = "Work AM"
Case WorkPM
WorkTypeStr = "Work PM"
Case Else
WorkTypeStr = "Error"
End Select
'don't output anything if not schedule
If Len(WorkTypeStr) > 0 Then
.Cells( _
(FirstShiftRow + EmployeeCount + SkipRows), ColCount) = _
WorkTypeStr
End If
Next EmployeeCount
End With
ColCount = ColCount + 1
DayOfYear = DayOfYear + 1
DayCount = DayCount + 1
Loop
'format columns in last month
MonthSht.Columns.AutoFit
End Sub
--------------------
