Hi ..
I have an employee schedule that contains 3 shifts covering 24 hours. I want the work schedule to be the same without change for two weeks, while maintaining the number of employees in each shift at no less than 7 daily throughout the month, and the work schedule is 6 days, with the seventh day off.
Code_Goes_HereSub AssignShifts()
Dim ws As Worksheet
Dim employees As Range
Dim days As Integer, i As Integer, j As Integer
Dim shifts(3) As String
Dim colors(3) As Long
Dim empShifts(28, 31) As String
Set ws = ActiveSheet
Set rng = ws.Range("Table")
' Define shift symbols and colors
shifts(1) = "D": colors(1) = RGB(0, 0, 255) ' Blue for Day
shifts(2) = "E": colors(2) = RGB(0, 128, 0) ' Green for Evening
shifts(3) = "N": colors(3) = RGB(255, 0, 0) ' Red for Night
Set ws = ThisWorkbook.Sheets("Sheet1") ' Change to your sheet name
Set employees = ws.Range("B12:B39") ' 28 employees listed from D12 to D39
days = 30 ' Number of days in the month
' Clear previous assignments
ws.Range("D12:AH39").ClearContents
ws.Range("D12:AH39").Interior.ColorIndex = xlNone
' Fixed two-week pattern per employee group
' Divide 28 employees into 3 groups for rotation (approx. 9-10 employees per group)
Dim shiftGroup As Integer
Dim empStartCol As Integer
Dim empShift As String
For i = 1 To 28
shiftGroup = ((i - 1) Mod 3) + 1 ' Cycle groups 1, 2, 3 for D, E, N
For j = 1 To days
empStartCol = j + 4 ' Adjust column (E is column 5)
' Determine 2-week cycle shift
Select Case ((Int((j - 1) / 14) + shiftGroup - 1) Mod 3) + 1
Case 1: empShift = "D"
Case 2: empShift = "E"
Case 3: empShift = "N"
End Select
' Assign OFF on every 7th day of the cycle (6 work days, then OFF)
If (j Mod 7 = 0) Then
ws.Cells(i + 11, empStartCol).Value = "OFF"
ws.Cells(i + 11, empStartCol).Interior.ColorIndex = xlNone
Else
ws.Cells(i + 11, empStartCol).Value = empShift
Select Case empShift
Case "D": ws.Cells(i + 11, empStartCol).Interior.Color = colors(1)
Case "E": ws.Cells(i + 11, empStartCol).Interior.Color = colors(2)
Case "N": ws.Cells(i + 11, empStartCol).Interior.Color = colors(3)
End Select
End If
Next j
Next i
MsgBox "Fixed 2-week rotating shift schedule completed!", vbInformation
End Sub