Employee Schedule Creator

' Employee Schedule Creator
' Employees sheet: Name (A), Role (B), Max Hours/Week (C), Availability (D)
' Schedule sheet: Employee (row), Days (columns), Shift codes in cells
' Shift codes: M=Morning, A=Afternoon, N=Night, O=Off, H=Holiday

Sub CreateWeeklySchedule()
    ' Set up a blank weekly schedule grid
    On Error GoTo ErrorHandler

    Application.ScreenUpdating = False

    ' Get employees
    Dim wsEmp As Worksheet
    On Error Resume Next
    Set wsEmp = ThisWorkbook.Sheets("Employees")
    On Error GoTo ErrorHandler

    If wsEmp Is Nothing Then
        MsgBox "Please create an 'Employees' sheet with columns: Name, Role, Max Hours/Week, Availability", vbExclamation
        Exit Sub
    End If

    Dim lastEmpRow As Long
    lastEmpRow = wsEmp.Cells(wsEmp.Rows.Count, "A").End(xlUp).Row

    If lastEmpRow < 2 Then
        MsgBox "No employees found in Employees sheet.", vbExclamation
        Exit Sub
    End If

    ' Get week start date
    Dim weekStart As Date
    Dim dateInput As String
    dateInput = InputBox("Enter week start date (dd/mm/yyyy):", "Schedule Week", Format(Date - Weekday(Date, vbMonday) + 1, "dd/mm/yyyy"))
    If dateInput = "" Then Exit Sub
    weekStart = CDate(dateInput)

    ' Create schedule sheet
    Dim wsSched As Worksheet
    Dim schedName As String
    schedName = "Week " & Format(weekStart, "dd-mm")

    On Error Resume Next
    Set wsSched = ThisWorkbook.Sheets(schedName)
    On Error GoTo ErrorHandler

    If wsSched Is Nothing Then
        Set wsSched = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        wsSched.Name = schedName
    Else
        wsSched.Cells.Clear
    End If

    ' Title
    wsSched.Cells(1, 1).Value = "Employee Schedule - Week of " & Format(weekStart, "dd/mm/yyyy")
    wsSched.Cells(1, 1).Font.Size = 14
    wsSched.Cells(1, 1).Font.Bold = True
    wsSched.Range("A1:H1").Merge

    ' Legend
    wsSched.Cells(2, 1).Value = "Shift Codes: M=Morning (06:00-14:00) | A=Afternoon (14:00-22:00) | N=Night (22:00-06:00) | O=Off | H=Holiday"
    wsSched.Cells(2, 1).Font.Size = 9
    wsSched.Cells(2, 1).Font.Italic = True

    ' Day headers
    wsSched.Cells(4, 1).Value = "Employee"
    wsSched.Cells(4, 2).Value = "Role"

    Dim d As Long
    For d = 0 To 6
        Dim dayDate As Date
        dayDate = weekStart + d

        wsSched.Cells(4, d + 3).Value = Format(dayDate, "ddd") & vbCrLf & Format(dayDate, "dd/mm")
        wsSched.Cells(4, d + 3).WrapText = True
        wsSched.Cells(4, d + 3).HorizontalAlignment = xlCenter
    Next d

    wsSched.Cells(4, 10).Value = "Total Hours"

    ' Format headers
    With wsSched.Range("A4:J4")
        .Font.Bold = True
        .Interior.Color = RGB(0, 102, 204)
        .Font.Color = RGB(255, 255, 255)
        .HorizontalAlignment = xlCenter
    End With

    ' Add employees
    Dim row As Long
    row = 5

    Dim i As Long
    For i = 2 To lastEmpRow
        wsSched.Cells(row, 1).Value = wsEmp.Cells(i, 1).Value
        wsSched.Cells(row, 2).Value = wsEmp.Cells(i, 2).Value

        ' Default all days to empty for manual assignment
        For d = 3 To 9
            wsSched.Cells(row, d).HorizontalAlignment = xlCenter
            wsSched.Cells(row, d).Font.Size = 12

            ' Add data validation for shift codes
            With wsSched.Cells(row, d).Validation
                .Delete
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
                    Formula1:="M,A,N,O,H"
                .IgnoreBlank = True
                .ShowInput = True
                .ShowError = True
                .InputTitle = "Shift Code"
                .InputMessage = "M=Morning, A=Afternoon, N=Night, O=Off, H=Holiday"
                .ErrorTitle = "Invalid Shift"
                .ErrorMessage = "Please enter M, A, N, O, or H"
            End With
        Next d

        ' Alternate row shading
        If (row - 5) Mod 2 = 1 Then
            wsSched.Range("A" & row & ":J" & row).Interior.Color = RGB(240, 245, 250)
        End If

        row = row + 1
    Next i

    ' Set column widths
    wsSched.Columns("A").ColumnWidth = 20
    wsSched.Columns("B").ColumnWidth = 15
    wsSched.Columns("C:I").ColumnWidth = 12
    wsSched.Columns("J").ColumnWidth = 12

    ' Add borders
    With wsSched.Range("A4:J" & row - 1).Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
        .Color = RGB(180, 180, 180)
    End With

    Application.ScreenUpdating = True

    MsgBox "Weekly schedule created for " & Format(weekStart, "dd/mm/yyyy") & "." & vbCrLf & _
           "Enter shift codes (M/A/N/O/H) in the grid, then run 'Calculate Schedule Hours' to validate.", vbInformation

    Exit Sub

ErrorHandler:
    Application.ScreenUpdating = True
    MsgBox "Error creating schedule: " & Err.Description, vbCritical
End Sub

Sub CalculateScheduleHours()
    ' Calculate total hours and check for conflicts
    On Error GoTo ErrorHandler

    Dim ws As Worksheet
    Set ws = ActiveSheet

    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    If lastRow < 5 Then
        MsgBox "No schedule data found.", vbExclamation
        Exit Sub
    End If

    ' Shift hours mapping
    Dim shiftHours As Object
    Set shiftHours = CreateObject("Scripting.Dictionary")
    shiftHours.Add "M", 8   ' Morning: 8 hours
    shiftHours.Add "A", 8   ' Afternoon: 8 hours
    shiftHours.Add "N", 8   ' Night: 8 hours
    shiftHours.Add "O", 0   ' Off
    shiftHours.Add "H", 0   ' Holiday

    Dim conflicts As String
    Dim warnings As String

    Dim i As Long
    For i = 5 To lastRow
        Dim totalHours As Double
        totalHours = 0

        Dim consecutiveDays As Long
        consecutiveDays = 0

        Dim d As Long
        For d = 3 To 9
            Dim shiftCode As String
            shiftCode = UCase(Trim(ws.Cells(i, d).Value))

            If shiftCode <> "" And shiftHours.Exists(shiftCode) Then
                totalHours = totalHours + shiftHours(shiftCode)

                ' Track consecutive working days
                If shiftCode <> "O" And shiftCode <> "H" Then
                    consecutiveDays = consecutiveDays + 1
                Else
                    consecutiveDays = 0
                End If

                ' Colour code shifts
                Select Case shiftCode
                    Case "M"
                        ws.Cells(i, d).Interior.Color = RGB(200, 230, 255)
                    Case "A"
                        ws.Cells(i, d).Interior.Color = RGB(255, 240, 200)
                    Case "N"
                        ws.Cells(i, d).Interior.Color = RGB(220, 200, 255)
                    Case "O"
                        ws.Cells(i, d).Interior.Color = RGB(230, 230, 230)
                    Case "H"
                        ws.Cells(i, d).Interior.Color = RGB(200, 240, 200)
                End Select
            End If
        Next d

        ' Write total hours
        ws.Cells(i, 10).Value = totalHours
        ws.Cells(i, 10).Font.Bold = True

        ' Check for excessive hours
        If totalHours > 48 Then
            warnings = warnings & ws.Cells(i, 1).Value & ": " & totalHours & " hours (exceeds 48hr limit)" & vbCrLf
            ws.Cells(i, 10).Interior.Color = RGB(255, 150, 150)
        ElseIf totalHours > 40 Then
            ws.Cells(i, 10).Interior.Color = RGB(255, 230, 150)
        End If

        ' Check for 7 consecutive days
        If consecutiveDays >= 7 Then
            warnings = warnings & ws.Cells(i, 1).Value & ": 7 consecutive working days" & vbCrLf
        End If
    Next i

    ' Show results
    If warnings <> "" Then
        MsgBox "Schedule Warnings:" & vbCrLf & vbCrLf & warnings, vbExclamation, "Schedule Check"
    Else
        MsgBox "Schedule validated. No issues found.", vbInformation
    End If

    Exit Sub

ErrorHandler:
    MsgBox "Error calculating hours: " & Err.Description, vbCritical
End Sub