From 2c6b612d6254c6463223bfd82a5b4a2cb6d512f8 Mon Sep 17 00:00:00 2001 From: Casielim Date: Tue, 8 Jul 2025 22:54:15 +0800 Subject: [PATCH 1/5] Add AssignAOHDuties.bas --- VBA/VBA-Code_By_Modules/AssignAOHDuties.bas | 245 ++++++++++++++++++++ 1 file changed, 245 insertions(+) create mode 100644 VBA/VBA-Code_By_Modules/AssignAOHDuties.bas diff --git a/VBA/VBA-Code_By_Modules/AssignAOHDuties.bas b/VBA/VBA-Code_By_Modules/AssignAOHDuties.bas new file mode 100644 index 0000000..d1fb8f5 --- /dev/null +++ b/VBA/VBA-Code_By_Modules/AssignAOHDuties.bas @@ -0,0 +1,245 @@ +Attribute VB_Name = "AssignAOHDuties" +' Declare worksheet and table +Private wsRosterCopy As Worksheet +Private wsPersonnel As Worksheet +Private wsSettings As Worksheet +Private aohtbl As ListObject +Private spectbl As ListObject + +' Declare roster column numbers +Private Const VAC_COL As Long = 1 +Private Const DATE_COL As Long = 2 +Private Const DAY_COL As Long = 3 +Private Const LMB_COL As Long = 4 +Private Const MOR_COL As Long = 6 +Private Const AFT_COL As Long = 8 +Private Const AOH_COL As Long = 10 +Private Const SAT_AOH_COL1 As Long = 12 +Private Const SAT_AOH_COL2 As Long = 14 +Private Const START_ROW As Long = 6 + +Sub AssignAOHDuties() + Set wsRosterCopy = Sheets("MasterCopy (2)") + Set wsSettings = Sheets("Settings") + Set wsPersonnel = Sheets("AOH PersonnelList") + Set aohtbl = wsPersonnel.ListObjects("AOHMainList") + Set spectbl = wsPersonnel.ListObjects("AOHSpecificDaysWorkingStaff") + + Dim i As Long, j As Long, r As Long + Dim dateCount As Long + Dim totalDays As Long + Dim dayName As String + Dim maxDuties As Long + Dim staffName As String + Dim workDays As Variant + + totalDays = wsRosterCopy.Range(wsRosterCopy.Cells(START_ROW, DATE_COL), wsRosterCopy.Cells(186, DATE_COL)).Rows.Count + + ' Step 1: Assign Specific Days Staff with weekly limit + For i = 1 To spectbl.ListRows.Count + staffName = spectbl.DataBodyRange(i, spectbl.ListColumns("Name").Index).Value + Debug.Print "Processing Specific Days staff: " & staffName + workDays = Split(spectbl.DataBodyRange(i, spectbl.ListColumns("Working Days").Index).Value, ",") + + ' Clean up day names (remove spaces) + For j = 0 To UBound(workDays) + workDays(j) = Trim(workDays(j)) + Next j + + ' Get max duties for this staff from MorningMainList + For r = 1 To aohtbl.ListRows.Count + If aohtbl.DataBodyRange(r, aohtbl.ListColumns("Name").Index).Value = staffName Then + maxDuties = aohtbl.DataBodyRange(r, aohtbl.ListColumns("Max Duties").Index).Value + Exit For + End If + Next r + + ' Build candidate pool of eligible rows + Dim eligibleRows As Collection + Set eligibleRows = GetEligibleRows(totalDays, workDays) + + ' Shuffle eligibleRows randomly + Dim tmpRows() As Long + ReDim tmpRows(1 To eligibleRows.Count) + For j = 1 To eligibleRows.Count + tmpRows(j) = eligibleRows(j) + Next j + Call ShuffleArray(tmpRows) + + ' Assign staff with weekly limit check + Dim assigned As Long + assigned = 0 + For j = 1 To eligibleRows.Count + If assigned >= maxDuties Then Exit For + r = tmpRows(j) + Debug.Print "Considering row " & r & " for " & staffName & " (Shuffled index: " & j & ")" + + Dim weekStart As Long, weekEnd As Long + weekStart = r - (Weekday(wsRosterCopy.Cells(r, DATE_COL).Value, vbMonday) - 1) + If weekStart < START_ROW Then weekStart = START_ROW + weekEnd = weekStart + 6 + If weekEnd >= 186 Then weekEnd = 186 - 1 + Debug.Print " Week boundaries: Start = " & weekStart & ", End = " & weekEnd + + Dim dutyCount As Long + dutyCount = 0 + For k = weekStart To weekEnd + If k >= START_ROW And k < 186 And wsRosterCopy.Cells(k, AOH_COL).Value = staffName And _ + UCase(Trim(wsRosterCopy.Cells(k, VAC_COL).Value)) = "SEM TIME" Then + dutyCount = dutyCount + 1 + End If + Next k + Debug.Print " Current duty count in week: " & dutyCount + + If wsRosterCopy.Cells(r, AOH_COL).Value = "" And CheckWeeklyLimit(staffName, r, START_ROW, 186) Then + wsRosterCopy.Cells(r, AOH_COL).Value = staffName + Call IncrementDutiesCounter(staffName) + assigned = assigned + 1 + Debug.Print " Assigned " & staffName & " to row " & r & " (Duty count: " & assigned & ")" + Else + Debug.Print " Skipped row " & r & " for " & staffName & " (Limit reached or slot taken)" + End If + Next j + Debug.Print "Total assigned to " & staffName & ": " & assigned + Next i + + ' Step 2: Assign All Days Staff with weekly limit + For r = START_ROW To 186 + If wsRosterCopy.Cells(r, DAY_COL).Value = "Sat" Then GoTo SkipDay + If wsRosterCopy.Cells(r, AOH_COL).Value = "CLOSED" Then GoTo SkipDay + ' Check if the day is sem time (not vacation) + If UCase(Trim(wsRosterCopy.Cells(r, VAC_COL).Value)) <> "SEM TIME" Then GoTo SkipDay + + For i = 1 To aohtbl.ListRows.Count + staffName = aohtbl.DataBodyRange(i, aohtbl.ListColumns("Name").Index).Value + If UCase(aohtbl.DataBodyRange(i, aohtbl.ListColumns("Availability Type").Index).Value) = "SPECIFIC DAYS" Then + GoTo SkipStaff + End If + + maxDuties = aohtbl.DataBodyRange(i, aohtbl.ListColumns("Max Duties").Index).Value + Dim currDuties As Long + currDuties = aohtbl.DataBodyRange(i, aohtbl.ListColumns("Duties Counter").Index).Value + ' Check if the staff already reached his max duties + If currDuties >= maxDuties Then GoTo SkipStaff + + ' Assign from top with weekly limit check + If wsRosterCopy.Cells(r, AOH_COL).Value = "" And CheckWeeklyLimit(staffName, r, START_ROW, 186) Then + wsRosterCopy.Cells(r, AOH_COL).Value = staffName + Call IncrementDutiesCounter(staffName) + ' Debug.Print "Assigned All Days staff " & staffName & " to row " & r + Exit For + End If + +SkipStaff: + Next i + +SkipDay: + Next r + + MsgBox "Duties assignment completed!", vbInformation +End Sub + +' Helper to shuffle array +Sub ShuffleArray(arr() As Long) + Dim i As Long, j As Long, tmp As Long + Randomize + For i = UBound(arr) To LBound(arr) + 1 Step -1 + j = Int(Rnd() * (i - LBound(arr) + 1)) + LBound(arr) + tmp = arr(i) + arr(i) = arr(j) + arr(j) = tmp + Next i +End Sub + +Function GetEligibleRows(totalDays As Long, workDays As Variant) As Collection + Dim eligibleRows As New Collection + Dim r As Long, j As Long + Dim dayName As String + + Debug.Print "=== Checking Eligible Rows ===" + Debug.Print "WorkDays:" + For j = LBound(workDays) To UBound(workDays) + Debug.Print "[" & j & "]: " & workDays(j) + Next j + + For r = START_ROW To 186 + dayName = Trim(wsRosterCopy.Cells(r, DAY_COL).Value) + Debug.Print "Row " & r & ": " & dayName + + ' Skip if already filled + If Not IsEmpty(wsRosterCopy.Cells(r, AOH_COL)) Then + Debug.Print " -> Skipped (Already Assigned)" + GoTo SkipRow + End If + + ' Check if the day is within sem time + If UCase(Trim(wsRosterCopy.Cells(r, VAC_COL).Value)) <> "SEM TIME" Then + Debug.Print " -> Skipped (Not Sem Time)" + GoTo SkipRow + End If + + ' Check if the day is in workDays + For j = LBound(workDays) To UBound(workDays) + If dayName = workDays(j) Then + eligibleRows.Add r + Debug.Print " -> Added (Matched with " & workDays(j) & ")" + Exit For + End If + Next j + +SkipRow: + Next r + Debug.Print "Total Eligible: " & eligibleRows.Count + Set GetEligibleRows = eligibleRows +End Function + +Sub IncrementDutiesCounter(staffName As String) + Dim rowIdx As Variant + Dim foundCell As Range + + ' Search for the staff name + Set foundCell = aohtbl.ListColumns("Name").DataBodyRange.Find( _ + What:=staffName, LookIn:=xlValues, LookAt:=xlWhole) + + If Not foundCell Is Nothing Then + ' Get relative row index in the table + rowIdx = foundCell.Row - aohtbl.HeaderRowRange.Row + + ' Increment Duties Counter + With aohtbl.ListRows(rowIdx).Range.Cells(aohtbl.ListColumns("Duties Counter").Index) + .Value = .Value + 1 + End With + Else + MsgBox "Staff '" & staffName & "' not found in table.", vbExclamation + End If +End Sub + + + +Function CheckWeeklyLimit(staffName As String, rowNum As Long, startRow As Long, endRow As Long) As Boolean + Dim ws As Worksheet + Dim i As Long + Dim weekStart As Long + Dim weekEnd As Long + Dim dutyCount As Long + + Set ws = wsRosterCopy + weekStart = rowNum - (Weekday(ws.Cells(rowNum, DATE_COL).Value, vbMonday) - 1) + If weekStart < startRow Then weekStart = startRow + weekEnd = weekStart + 6 + If weekEnd >= endRow Then weekEnd = endRow - 1 + + ' Debug.Print "Row " & rowNum & ": Week Start = " & weekStart & ", Week End = " & weekEnd + dutyCount = 0 + For i = weekStart To weekEnd + If i >= startRow And i < endRow And ws.Cells(i, AOH_COL).Value = staffName And UCase(Trim(ws.Cells(i, VAC_COL).Value)) = "SEM TIME" Then + dutyCount = dutyCount + 1 + If dutyCount >= 1 Then + CheckWeeklyLimit = False + Exit Function + End If + End If + Next i + CheckWeeklyLimit = True +End Function + From 02ed56e453b7033df893be155a16798b4e3711bc Mon Sep 17 00:00:00 2001 From: Casielim Date: Tue, 8 Jul 2025 22:55:29 +0800 Subject: [PATCH 2/5] Use global variable LAST_ROW_ROSTER --- VBA/VBA-Code_By_Modules/AssignAOHDuties.bas | 20 +++++++++----------- 1 file changed, 9 insertions(+), 11 deletions(-) diff --git a/VBA/VBA-Code_By_Modules/AssignAOHDuties.bas b/VBA/VBA-Code_By_Modules/AssignAOHDuties.bas index d1fb8f5..412fb3e 100644 --- a/VBA/VBA-Code_By_Modules/AssignAOHDuties.bas +++ b/VBA/VBA-Code_By_Modules/AssignAOHDuties.bas @@ -33,7 +33,7 @@ Sub AssignAOHDuties() Dim staffName As String Dim workDays As Variant - totalDays = wsRosterCopy.Range(wsRosterCopy.Cells(START_ROW, DATE_COL), wsRosterCopy.Cells(186, DATE_COL)).Rows.Count + totalDays = wsRosterCopy.Range(wsRosterCopy.Cells(START_ROW, DATE_COL), wsRosterCopy.Cells(LAST_ROW_ROSTER, DATE_COL)).Rows.Count ' Step 1: Assign Specific Days Staff with weekly limit For i = 1 To spectbl.ListRows.Count @@ -78,20 +78,20 @@ Sub AssignAOHDuties() weekStart = r - (Weekday(wsRosterCopy.Cells(r, DATE_COL).Value, vbMonday) - 1) If weekStart < START_ROW Then weekStart = START_ROW weekEnd = weekStart + 6 - If weekEnd >= 186 Then weekEnd = 186 - 1 + If weekEnd >= LAST_ROW_ROSTER Then weekEnd = LAST_ROW_ROSTER - 1 Debug.Print " Week boundaries: Start = " & weekStart & ", End = " & weekEnd Dim dutyCount As Long dutyCount = 0 For k = weekStart To weekEnd - If k >= START_ROW And k < 186 And wsRosterCopy.Cells(k, AOH_COL).Value = staffName And _ + If k >= START_ROW And k < LAST_ROW_ROSTER And wsRosterCopy.Cells(k, AOH_COL).Value = staffName And _ UCase(Trim(wsRosterCopy.Cells(k, VAC_COL).Value)) = "SEM TIME" Then dutyCount = dutyCount + 1 End If Next k Debug.Print " Current duty count in week: " & dutyCount - If wsRosterCopy.Cells(r, AOH_COL).Value = "" And CheckWeeklyLimit(staffName, r, START_ROW, 186) Then + If wsRosterCopy.Cells(r, AOH_COL).Value = "" And CheckWeeklyLimit(staffName, r, START_ROW, LAST_ROW_ROSTER) Then wsRosterCopy.Cells(r, AOH_COL).Value = staffName Call IncrementDutiesCounter(staffName) assigned = assigned + 1 @@ -104,7 +104,7 @@ Sub AssignAOHDuties() Next i ' Step 2: Assign All Days Staff with weekly limit - For r = START_ROW To 186 + For r = START_ROW To LAST_ROW_ROSTER If wsRosterCopy.Cells(r, DAY_COL).Value = "Sat" Then GoTo SkipDay If wsRosterCopy.Cells(r, AOH_COL).Value = "CLOSED" Then GoTo SkipDay ' Check if the day is sem time (not vacation) @@ -123,10 +123,10 @@ Sub AssignAOHDuties() If currDuties >= maxDuties Then GoTo SkipStaff ' Assign from top with weekly limit check - If wsRosterCopy.Cells(r, AOH_COL).Value = "" And CheckWeeklyLimit(staffName, r, START_ROW, 186) Then + If wsRosterCopy.Cells(r, AOH_COL).Value = "" And CheckWeeklyLimit(staffName, r, START_ROW, LAST_ROW_ROSTER) Then wsRosterCopy.Cells(r, AOH_COL).Value = staffName Call IncrementDutiesCounter(staffName) - ' Debug.Print "Assigned All Days staff " & staffName & " to row " & r + Debug.Print "Assigned All Days staff " & staffName & " to row " & r Exit For End If @@ -162,7 +162,7 @@ Function GetEligibleRows(totalDays As Long, workDays As Variant) As Collection Debug.Print "[" & j & "]: " & workDays(j) Next j - For r = START_ROW To 186 + For r = START_ROW To LAST_ROW_ROSTER dayName = Trim(wsRosterCopy.Cells(r, DAY_COL).Value) Debug.Print "Row " & r & ": " & dayName @@ -214,8 +214,6 @@ Sub IncrementDutiesCounter(staffName As String) End If End Sub - - Function CheckWeeklyLimit(staffName As String, rowNum As Long, startRow As Long, endRow As Long) As Boolean Dim ws As Worksheet Dim i As Long @@ -229,7 +227,7 @@ Function CheckWeeklyLimit(staffName As String, rowNum As Long, startRow As Long, weekEnd = weekStart + 6 If weekEnd >= endRow Then weekEnd = endRow - 1 - ' Debug.Print "Row " & rowNum & ": Week Start = " & weekStart & ", Week End = " & weekEnd + Debug.Print "Row " & rowNum & ": Week Start = " & weekStart & ", Week End = " & weekEnd dutyCount = 0 For i = weekStart To weekEnd If i >= startRow And i < endRow And ws.Cells(i, AOH_COL).Value = staffName And UCase(Trim(ws.Cells(i, VAC_COL).Value)) = "SEM TIME" Then From a7680dfc858b5b0cbd589e8cfb4b30cf01ecb824 Mon Sep 17 00:00:00 2001 From: Casielim Date: Fri, 18 Jul 2025 14:12:18 +0800 Subject: [PATCH 3/5] Implement reassignment --- VBA/VBA-Code_By_Modules/AssignAOHDuties.bas | 194 ++++++++++++++++++-- 1 file changed, 178 insertions(+), 16 deletions(-) diff --git a/VBA/VBA-Code_By_Modules/AssignAOHDuties.bas b/VBA/VBA-Code_By_Modules/AssignAOHDuties.bas index 412fb3e..3d2617c 100644 --- a/VBA/VBA-Code_By_Modules/AssignAOHDuties.bas +++ b/VBA/VBA-Code_By_Modules/AssignAOHDuties.bas @@ -123,8 +123,8 @@ Sub AssignAOHDuties() If currDuties >= maxDuties Then GoTo SkipStaff ' Assign from top with weekly limit check - If wsRosterCopy.Cells(r, AOH_COL).Value = "" And CheckWeeklyLimit(staffName, r, START_ROW, LAST_ROW_ROSTER) Then - wsRosterCopy.Cells(r, AOH_COL).Value = staffName + If wsRoster.Cells(r, AOH_COL).Value = "" And CheckWeeklyLimit(staffName, r, START_ROW, LAST_ROW_ROSTER) Then + wsRoster.Cells(r, AOH_COL).Value = staffName Call IncrementDutiesCounter(staffName) Debug.Print "Assigned All Days staff " & staffName & " to row " & r Exit For @@ -136,6 +136,135 @@ SkipStaff: SkipDay: Next r + ' Step 3: Reassign All Days Staff for last 2 weeks with random assignment + Dim needsReassignment As Boolean + Do + needsReassignment = False + Dim lastTwoWeeksStart As Long + lastTwoWeeksStart = LAST_ROW_ROSTER - 13 ' Last 14 days (2 weeks) + If lastTwoWeeksStart < START_ROW Then lastTwoWeeksStart = START_ROW + + ' Check if any All Days staff need reassignment + For i = 1 To aohtbl.ListRows.Count + staffName = aohtbl.DataBodyRange(i, aohtbl.ListColumns("Name").Index).Value + maxDuties = aohtbl.DataBodyRange(i, aohtbl.ListColumns("Max Duties").Index).Value + currDuties = aohtbl.DataBodyRange(i, aohtbl.ListColumns("Duties Counter").Index).Value + If UCase(aohtbl.DataBodyRange(i, aohtbl.ListColumns("Availability Type").Index).Value) <> "SPECIFIC DAYS" And currDuties < maxDuties Then + needsReassignment = True + Debug.Print "Staff " & staffName & " needs reassignment (Current: " & currDuties & ", Max: " & maxDuties & ")" + End If + Next i + + If needsReassignment Then + ' Remove existing assignments for All Days staff in last 2 weeks and collect staff needing reassignment + Dim removedStaff() As String + ReDim removedStaff(0) + For r = lastTwoWeeksStart To LAST_ROW_ROSTER + If wsRoster.Cells(r, AOH_COL).Value <> "" And wsRoster.Cells(r, AOH_COL).Value <> "CLOSED" Then + staffName = wsRoster.Cells(r, AOH_COL).Value + For i = 1 To aohtbl.ListRows.Count + If aohtbl.DataBodyRange(i, aohtbl.ListColumns("Name").Index).Value = staffName And _ + UCase(aohtbl.DataBodyRange(i, aohtbl.ListColumns("Availability Type").Index).Value) <> "SPECIFIC DAYS" Then + wsRoster.Cells(r, AOH_COL).Value = "" + Call DecrementDutiesCounter(staffName) + Debug.Print "Removed " & staffName & " from row " & r & " (Last 2 weeks)" + ' Add to removedStaff array if not already present + Dim found As Boolean + found = False + For j = LBound(removedStaff) To UBound(removedStaff) + If removedStaff(j) = staffName Then found = True + Next j + If Not found Then + ReDim Preserve removedStaff(UBound(removedStaff) + 1) + removedStaff(UBound(removedStaff)) = staffName + End If + Exit For + End If + Next i + End If + Next r + + ' Build staff pool with only All Days staff needing reassignment (currDuties < maxDuties) + Dim staffPool() As String + ReDim staffPool(0) + For i = 1 To aohtbl.ListRows.Count + staffName = aohtbl.DataBodyRange(i, aohtbl.ListColumns("Name").Index).Value + If UCase(aohtbl.DataBodyRange(i, aohtbl.ListColumns("Availability Type").Index).Value) <> "SPECIFIC DAYS" Then + maxDuties = aohtbl.DataBodyRange(i, aohtbl.ListColumns("Max Duties").Index).Value + currDuties = aohtbl.DataBodyRange(i, aohtbl.ListColumns("Duties Counter").Index).Value + If currDuties < maxDuties Then + found = False + For j = LBound(staffPool) To UBound(staffPool) + If staffPool(j) = staffName Then found = True + Next j + If Not found Then + ReDim Preserve staffPool(UBound(staffPool) + 1) + staffPool(UBound(staffPool)) = staffName + End If + End If + End If + Next i + + ' Combine removed staff with staff pool (avoid duplicates) + For j = LBound(removedStaff) To UBound(removedStaff) + If removedStaff(j) <> "" Then + found = False + For k = LBound(staffPool) To UBound(staffPool) + If staffPool(k) = removedStaff(j) Then found = True + Next k + If Not found Then + ReDim Preserve staffPool(UBound(staffPool) + 1) + staffPool(UBound(staffPool)) = removedStaff(j) + End If + End If + Next j + + ' Shuffle staff pool + Dim tmpStaff() As String + If UBound(staffPool) > 0 Then + ReDim tmpStaff(1 To UBound(staffPool)) + For j = 1 To UBound(staffPool) + tmpStaff(j) = staffPool(j) + Next j + Call ShuffleArrayString(tmpStaff) + End If + + ' Reassign randomly from staff pool + Dim assignedInThisPass As Boolean + assignedInThisPass = False + For r = lastTwoWeeksStart To LAST_ROW_ROSTER + If wsRoster.Cells(r, DAY_COL).Value = "Sat" Then GoTo SkipReassignDay + If wsRoster.Cells(r, AOH_COL).Value <> "" Or wsRoster.Cells(r, AOH_COL).Value = "CLOSED" Then GoTo SkipReassignDay + If UCase(Trim(wsRoster.Cells(r, VAC_COL).Value)) <> "SEM TIME" Then GoTo SkipReassignDay + + For i = 1 To UBound(tmpStaff) + staffName = tmpStaff(i) + For j = 1 To aohtbl.ListRows.Count + If aohtbl.DataBodyRange(j, aohtbl.ListColumns("Name").Index).Value = staffName And _ + UCase(aohtbl.DataBodyRange(j, aohtbl.ListColumns("Availability Type").Index).Value) <> "SPECIFIC DAYS" Then + maxDuties = aohtbl.DataBodyRange(j, aohtbl.ListColumns("Max Duties").Index).Value + currDuties = aohtbl.DataBodyRange(j, aohtbl.ListColumns("Duties Counter").Index).Value + If currDuties < maxDuties And CheckWeeklyLimit(staffName, r, START_ROW, LAST_ROW_ROSTER) Then + wsRoster.Cells(r, AOH_COL).Value = staffName + Call IncrementDutiesCounter(staffName) + Debug.Print "Reassigned All Days staff " & staffName & " to row " & r & " (Last 2 weeks)" + assignedInThisPass = True + Exit For + Else + Debug.Print " Skipped " & staffName & " at row " & r & " (Limit reached or same-day conflict)" + End If + End If + Next j + If wsRoster.Cells(r, AOH_COL).Value <> "" Then Exit For + Next i +SkipReassignDay: + Next r + + ' If no assignments were made in this pass, break the loop to avoid infinite cycling + If Not assignedInThisPass Then needsReassignment = False + End If + Loop Until Not needsReassignment + MsgBox "Duties assignment completed!", vbInformation End Sub @@ -150,31 +279,42 @@ Sub ShuffleArray(arr() As Long) arr(j) = tmp Next i End Sub +' Helper to shuffle array of strings +Sub ShuffleArrayString(arr() As String) + Dim i As Long, j As Long, tmp As String + Randomize + For i = UBound(arr) To LBound(arr) + 1 Step -1 + j = Int(Rnd() * (i - LBound(arr) + 1)) + LBound(arr) + tmp = arr(i) + arr(i) = arr(j) + arr(j) = tmp + Next i +End Sub Function GetEligibleRows(totalDays As Long, workDays As Variant) As Collection Dim eligibleRows As New Collection Dim r As Long, j As Long Dim dayName As String - Debug.Print "=== Checking Eligible Rows ===" - Debug.Print "WorkDays:" + 'Debug.Print "=== Checking Eligible Rows ===" + 'Debug.Print "WorkDays:" For j = LBound(workDays) To UBound(workDays) - Debug.Print "[" & j & "]: " & workDays(j) + 'Debug.Print "[" & j & "]: " & workDays(j) Next j For r = START_ROW To LAST_ROW_ROSTER - dayName = Trim(wsRosterCopy.Cells(r, DAY_COL).Value) - Debug.Print "Row " & r & ": " & dayName + dayName = Trim(wsRoster.Cells(r, DAY_COL).Value) + 'Debug.Print "Row " & r & ": " & dayName ' Skip if already filled - If Not IsEmpty(wsRosterCopy.Cells(r, AOH_COL)) Then - Debug.Print " -> Skipped (Already Assigned)" + If Not IsEmpty(wsRoster.Cells(r, AOH_COL)) Then + 'Debug.Print " -> Skipped (Already Assigned)" GoTo SkipRow End If ' Check if the day is within sem time - If UCase(Trim(wsRosterCopy.Cells(r, VAC_COL).Value)) <> "SEM TIME" Then - Debug.Print " -> Skipped (Not Sem Time)" + If UCase(Trim(wsRoster.Cells(r, VAC_COL).Value)) <> "SEM TIME" Then + 'Debug.Print " -> Skipped (Not Sem Time)" GoTo SkipRow End If @@ -182,7 +322,7 @@ Function GetEligibleRows(totalDays As Long, workDays As Variant) As Collection For j = LBound(workDays) To UBound(workDays) If dayName = workDays(j) Then eligibleRows.Add r - Debug.Print " -> Added (Matched with " & workDays(j) & ")" + 'Debug.Print " -> Added (Matched with " & workDays(j) & ")" Exit For End If Next j @@ -203,7 +343,7 @@ Sub IncrementDutiesCounter(staffName As String) If Not foundCell Is Nothing Then ' Get relative row index in the table - rowIdx = foundCell.Row - aohtbl.HeaderRowRange.Row + rowIdx = foundCell.row - aohtbl.HeaderRowRange.row ' Increment Duties Counter With aohtbl.ListRows(rowIdx).Range.Cells(aohtbl.ListColumns("Duties Counter").Index) @@ -214,6 +354,28 @@ Sub IncrementDutiesCounter(staffName As String) End If End Sub +Sub DecrementDutiesCounter(staffName As String) + Dim rowIdx As Variant + Dim foundCell As Range + + ' Search for the staff name + Set foundCell = aohtbl.ListColumns("Name").DataBodyRange.Find( _ + What:=staffName, LookIn:=xlValues, LookAt:=xlWhole) + + If Not foundCell Is Nothing Then + ' Get relative row index in the table + rowIdx = foundCell.row - aohtbl.HeaderRowRange.row + + ' Decrement Duties Counter + With aohtbl.ListRows(rowIdx).Range.Cells(aohtbl.ListColumns("Duties Counter").Index) + .Value = .Value - 1 + If .Value < 0 Then .Value = 0 ' Prevent negative values + End With + Else + MsgBox "Staff '" & staffName & "' not found in table.", vbExclamation + End If +End Sub + Function CheckWeeklyLimit(staffName As String, rowNum As Long, startRow As Long, endRow As Long) As Boolean Dim ws As Worksheet Dim i As Long @@ -221,16 +383,16 @@ Function CheckWeeklyLimit(staffName As String, rowNum As Long, startRow As Long, Dim weekEnd As Long Dim dutyCount As Long - Set ws = wsRosterCopy + Set ws = wsRoster weekStart = rowNum - (Weekday(ws.Cells(rowNum, DATE_COL).Value, vbMonday) - 1) If weekStart < startRow Then weekStart = startRow weekEnd = weekStart + 6 If weekEnd >= endRow Then weekEnd = endRow - 1 - Debug.Print "Row " & rowNum & ": Week Start = " & weekStart & ", Week End = " & weekEnd + Debug.Print "Row " & rowNum & ": Week Start = " & weekStart & ", End = " & weekEnd dutyCount = 0 For i = weekStart To weekEnd - If i >= startRow And i < endRow And ws.Cells(i, AOH_COL).Value = staffName And UCase(Trim(ws.Cells(i, VAC_COL).Value)) = "SEM TIME" Then + If i >= startRow And i < endRow And (ws.Cells(i, AOH_COL).Value = staffName Or ws.Cells(i, SAT_AOH_COL1).Value = staffName Or ws.Cells(i, SAT_AOH_COL2).Value = staffName) And UCase(Trim(ws.Cells(i, VAC_COL).Value)) = "SEM TIME" Then dutyCount = dutyCount + 1 If dutyCount >= 1 Then CheckWeeklyLimit = False From c2097dbbc663223ce654630f2d2aeb86a71dd5d3 Mon Sep 17 00:00:00 2001 From: Casielim Date: Fri, 18 Jul 2025 14:12:38 +0800 Subject: [PATCH 4/5] Make column variables public --- VBA/VBA-Code_By_Modules/AssignAOHDuties.bas | 38 +++++++-------------- 1 file changed, 13 insertions(+), 25 deletions(-) diff --git a/VBA/VBA-Code_By_Modules/AssignAOHDuties.bas b/VBA/VBA-Code_By_Modules/AssignAOHDuties.bas index 3d2617c..5d4ee34 100644 --- a/VBA/VBA-Code_By_Modules/AssignAOHDuties.bas +++ b/VBA/VBA-Code_By_Modules/AssignAOHDuties.bas @@ -1,31 +1,19 @@ Attribute VB_Name = "AssignAOHDuties" ' Declare worksheet and table -Private wsRosterCopy As Worksheet +Private wsRoster As Worksheet Private wsPersonnel As Worksheet Private wsSettings As Worksheet Private aohtbl As ListObject Private spectbl As ListObject -' Declare roster column numbers -Private Const VAC_COL As Long = 1 -Private Const DATE_COL As Long = 2 -Private Const DAY_COL As Long = 3 -Private Const LMB_COL As Long = 4 -Private Const MOR_COL As Long = 6 -Private Const AFT_COL As Long = 8 -Private Const AOH_COL As Long = 10 -Private Const SAT_AOH_COL1 As Long = 12 -Private Const SAT_AOH_COL2 As Long = 14 -Private Const START_ROW As Long = 6 - Sub AssignAOHDuties() - Set wsRosterCopy = Sheets("MasterCopy (2)") + Set wsRoster = Sheets("MasterCopy (2)") Set wsSettings = Sheets("Settings") Set wsPersonnel = Sheets("AOH PersonnelList") Set aohtbl = wsPersonnel.ListObjects("AOHMainList") Set spectbl = wsPersonnel.ListObjects("AOHSpecificDaysWorkingStaff") - Dim i As Long, j As Long, r As Long + Dim i As Long, j As Long, r As Long, k As Long Dim dateCount As Long Dim totalDays As Long Dim dayName As String @@ -33,7 +21,7 @@ Sub AssignAOHDuties() Dim staffName As String Dim workDays As Variant - totalDays = wsRosterCopy.Range(wsRosterCopy.Cells(START_ROW, DATE_COL), wsRosterCopy.Cells(LAST_ROW_ROSTER, DATE_COL)).Rows.Count + totalDays = wsRoster.Range(wsRoster.Cells(START_ROW, DATE_COL), wsRoster.Cells(LAST_ROW_ROSTER, DATE_COL)).Rows.Count ' Step 1: Assign Specific Days Staff with weekly limit For i = 1 To spectbl.ListRows.Count @@ -46,7 +34,7 @@ Sub AssignAOHDuties() workDays(j) = Trim(workDays(j)) Next j - ' Get max duties for this staff from MorningMainList + ' Get max duties for this staff from AOHMainList For r = 1 To aohtbl.ListRows.Count If aohtbl.DataBodyRange(r, aohtbl.ListColumns("Name").Index).Value = staffName Then maxDuties = aohtbl.DataBodyRange(r, aohtbl.ListColumns("Max Duties").Index).Value @@ -75,7 +63,7 @@ Sub AssignAOHDuties() Debug.Print "Considering row " & r & " for " & staffName & " (Shuffled index: " & j & ")" Dim weekStart As Long, weekEnd As Long - weekStart = r - (Weekday(wsRosterCopy.Cells(r, DATE_COL).Value, vbMonday) - 1) + weekStart = r - (Weekday(wsRoster.Cells(r, DATE_COL).Value, vbMonday) - 1) If weekStart < START_ROW Then weekStart = START_ROW weekEnd = weekStart + 6 If weekEnd >= LAST_ROW_ROSTER Then weekEnd = LAST_ROW_ROSTER - 1 @@ -84,15 +72,15 @@ Sub AssignAOHDuties() Dim dutyCount As Long dutyCount = 0 For k = weekStart To weekEnd - If k >= START_ROW And k < LAST_ROW_ROSTER And wsRosterCopy.Cells(k, AOH_COL).Value = staffName And _ - UCase(Trim(wsRosterCopy.Cells(k, VAC_COL).Value)) = "SEM TIME" Then + If k >= START_ROW And k < LAST_ROW_ROSTER And wsRoster.Cells(k, AOH_COL).Value = staffName And _ + UCase(Trim(wsRoster.Cells(k, VAC_COL).Value)) = "SEM TIME" Then dutyCount = dutyCount + 1 End If Next k Debug.Print " Current duty count in week: " & dutyCount - If wsRosterCopy.Cells(r, AOH_COL).Value = "" And CheckWeeklyLimit(staffName, r, START_ROW, LAST_ROW_ROSTER) Then - wsRosterCopy.Cells(r, AOH_COL).Value = staffName + If wsRoster.Cells(r, AOH_COL).Value = "" And CheckWeeklyLimit(staffName, r, START_ROW, LAST_ROW_ROSTER) Then + wsRoster.Cells(r, AOH_COL).Value = staffName Call IncrementDutiesCounter(staffName) assigned = assigned + 1 Debug.Print " Assigned " & staffName & " to row " & r & " (Duty count: " & assigned & ")" @@ -105,10 +93,10 @@ Sub AssignAOHDuties() ' Step 2: Assign All Days Staff with weekly limit For r = START_ROW To LAST_ROW_ROSTER - If wsRosterCopy.Cells(r, DAY_COL).Value = "Sat" Then GoTo SkipDay - If wsRosterCopy.Cells(r, AOH_COL).Value = "CLOSED" Then GoTo SkipDay + If wsRoster.Cells(r, DAY_COL).Value = "Sat" Then GoTo SkipDay + If wsRoster.Cells(r, AOH_COL).Value = "CLOSED" Then GoTo SkipDay ' Check if the day is sem time (not vacation) - If UCase(Trim(wsRosterCopy.Cells(r, VAC_COL).Value)) <> "SEM TIME" Then GoTo SkipDay + If UCase(Trim(wsRoster.Cells(r, VAC_COL).Value)) <> "SEM TIME" Then GoTo SkipDay For i = 1 To aohtbl.ListRows.Count staffName = aohtbl.DataBodyRange(i, aohtbl.ListColumns("Name").Index).Value From e544686133d7669fced0b8919ec75362ca82a8cd Mon Sep 17 00:00:00 2001 From: Casielim Date: Thu, 31 Jul 2025 22:27:50 +0800 Subject: [PATCH 5/5] Set reassignment --- VBA/VBA-Code_By_Modules/AssignAOHDuties.bas | 489 ++++++++++++-------- 1 file changed, 306 insertions(+), 183 deletions(-) diff --git a/VBA/VBA-Code_By_Modules/AssignAOHDuties.bas b/VBA/VBA-Code_By_Modules/AssignAOHDuties.bas index 5d4ee34..9978954 100644 --- a/VBA/VBA-Code_By_Modules/AssignAOHDuties.bas +++ b/VBA/VBA-Code_By_Modules/AssignAOHDuties.bas @@ -1,18 +1,13 @@ Attribute VB_Name = "AssignAOHDuties" -' Declare worksheet and table +' Declare worksheet and table at module level Private wsRoster As Worksheet -Private wsPersonnel As Worksheet Private wsSettings As Worksheet +Private wsPersonnel As Worksheet Private aohtbl As ListObject Private spectbl As ListObject Sub AssignAOHDuties() - Set wsRoster = Sheets("MasterCopy (2)") - Set wsSettings = Sheets("Settings") - Set wsPersonnel = Sheets("AOH PersonnelList") - Set aohtbl = wsPersonnel.ListObjects("AOHMainList") - Set spectbl = wsPersonnel.ListObjects("AOHSpecificDaysWorkingStaff") - + ' Variable declarations at the top Dim i As Long, j As Long, r As Long, k As Long Dim dateCount As Long Dim totalDays As Long @@ -20,11 +15,31 @@ Sub AssignAOHDuties() Dim maxDuties As Long Dim staffName As String Dim workDays As Variant + Dim eligibleRows As Collection + Dim tmpRows() As Long + Dim assignedCount As Long + Dim weekStart As Long, weekEnd As Long + Dim dutyCount As Long + Dim lastTwoWeeksStart As Long + Dim currDuties As Long + Dim priorityPool As Collection + Dim prioritySize As Long + Dim tmpStaff() As String + Dim targetWeek As Long + Dim anyPriorityAssignments As Boolean + Dim reassignmentAttempts As Long - totalDays = wsRoster.Range(wsRoster.Cells(START_ROW, DATE_COL), wsRoster.Cells(LAST_ROW_ROSTER, DATE_COL)).Rows.Count + ' Set worksheet and table references + Set wsRoster = Sheets("Roster") + Set wsSettings = Sheets("Settings") + Set wsPersonnel = Sheets("AOH PersonnelList") + Set aohtbl = wsPersonnel.ListObjects("AOHMainList") + Set spectbl = wsPersonnel.ListObjects("AOHSpecificDaysWorkingStaff") + + totalDays = wsRoster.Range(wsRoster.Cells(START_ROW, DATE_COL), wsRoster.Cells(last_row_roster, DATE_COL)).Rows.count ' Step 1: Assign Specific Days Staff with weekly limit - For i = 1 To spectbl.ListRows.Count + For i = 1 To spectbl.ListRows.count staffName = spectbl.DataBodyRange(i, spectbl.ListColumns("Name").Index).Value Debug.Print "Processing Specific Days staff: " & staffName workDays = Split(spectbl.DataBodyRange(i, spectbl.ListColumns("Working Days").Index).Value, ",") @@ -35,7 +50,7 @@ Sub AssignAOHDuties() Next j ' Get max duties for this staff from AOHMainList - For r = 1 To aohtbl.ListRows.Count + For r = 1 To aohtbl.ListRows.count If aohtbl.DataBodyRange(r, aohtbl.ListColumns("Name").Index).Value = staffName Then maxDuties = aohtbl.DataBodyRange(r, aohtbl.ListColumns("Max Duties").Index).Value Exit For @@ -43,43 +58,42 @@ Sub AssignAOHDuties() Next r ' Build candidate pool of eligible rows - Dim eligibleRows As Collection Set eligibleRows = GetEligibleRows(totalDays, workDays) ' Shuffle eligibleRows randomly - Dim tmpRows() As Long - ReDim tmpRows(1 To eligibleRows.Count) - For j = 1 To eligibleRows.Count + ReDim tmpRows(1 To eligibleRows.count) + For j = 1 To eligibleRows.count tmpRows(j) = eligibleRows(j) Next j Call ShuffleArray(tmpRows) ' Assign staff with weekly limit check - Dim assigned As Long assigned = 0 - For j = 1 To eligibleRows.Count + For j = 1 To eligibleRows.count If assigned >= maxDuties Then Exit For r = tmpRows(j) + If r = 0 Or r < START_ROW Or r > last_row_roster Then + Debug.Print "Invalid row number " & r & " for staff " & staffName & " at index " & j + GoTo NextIteration + End If Debug.Print "Considering row " & r & " for " & staffName & " (Shuffled index: " & j & ")" - Dim weekStart As Long, weekEnd As Long weekStart = r - (Weekday(wsRoster.Cells(r, DATE_COL).Value, vbMonday) - 1) If weekStart < START_ROW Then weekStart = START_ROW weekEnd = weekStart + 6 - If weekEnd >= LAST_ROW_ROSTER Then weekEnd = LAST_ROW_ROSTER - 1 + If weekEnd >= last_row_roster Then weekEnd = last_row_roster - 1 Debug.Print " Week boundaries: Start = " & weekStart & ", End = " & weekEnd - Dim dutyCount As Long dutyCount = 0 For k = weekStart To weekEnd - If k >= START_ROW And k < LAST_ROW_ROSTER And wsRoster.Cells(k, AOH_COL).Value = staffName And _ + If k >= START_ROW And k < last_row_roster And wsRoster.Cells(k, AOH_COL).Value = staffName And _ UCase(Trim(wsRoster.Cells(k, VAC_COL).Value)) = "SEM TIME" Then dutyCount = dutyCount + 1 End If Next k Debug.Print " Current duty count in week: " & dutyCount - If wsRoster.Cells(r, AOH_COL).Value = "" And CheckWeeklyLimit(staffName, r, START_ROW, LAST_ROW_ROSTER) Then + If wsRoster.Cells(r, AOH_COL).Value = "" And CheckWeeklyLimit(staffName, r, START_ROW, last_row_roster) Then wsRoster.Cells(r, AOH_COL).Value = staffName Call IncrementDutiesCounter(staffName) assigned = assigned + 1 @@ -87,31 +101,31 @@ Sub AssignAOHDuties() Else Debug.Print " Skipped row " & r & " for " & staffName & " (Limit reached or slot taken)" End If +NextIteration: Next j Debug.Print "Total assigned to " & staffName & ": " & assigned Next i ' Step 2: Assign All Days Staff with weekly limit - For r = START_ROW To LAST_ROW_ROSTER + For r = START_ROW To last_row_roster If wsRoster.Cells(r, DAY_COL).Value = "Sat" Then GoTo SkipDay If wsRoster.Cells(r, AOH_COL).Value = "CLOSED" Then GoTo SkipDay ' Check if the day is sem time (not vacation) If UCase(Trim(wsRoster.Cells(r, VAC_COL).Value)) <> "SEM TIME" Then GoTo SkipDay - For i = 1 To aohtbl.ListRows.Count + For i = 1 To aohtbl.ListRows.count staffName = aohtbl.DataBodyRange(i, aohtbl.ListColumns("Name").Index).Value If UCase(aohtbl.DataBodyRange(i, aohtbl.ListColumns("Availability Type").Index).Value) = "SPECIFIC DAYS" Then GoTo SkipStaff End If maxDuties = aohtbl.DataBodyRange(i, aohtbl.ListColumns("Max Duties").Index).Value - Dim currDuties As Long currDuties = aohtbl.DataBodyRange(i, aohtbl.ListColumns("Duties Counter").Index).Value ' Check if the staff already reached his max duties If currDuties >= maxDuties Then GoTo SkipStaff ' Assign from top with weekly limit check - If wsRoster.Cells(r, AOH_COL).Value = "" And CheckWeeklyLimit(staffName, r, START_ROW, LAST_ROW_ROSTER) Then + If wsRoster.Cells(r, AOH_COL).Value = "" And CheckWeeklyLimit(staffName, r, START_ROW, last_row_roster) Then wsRoster.Cells(r, AOH_COL).Value = staffName Call IncrementDutiesCounter(staffName) Debug.Print "Assigned All Days staff " & staffName & " to row " & r @@ -124,138 +138,258 @@ SkipStaff: SkipDay: Next r - ' Step 3: Reassign All Days Staff for last 2 weeks with random assignment - Dim needsReassignment As Boolean + ' Step 3: Reassign All Days Staff for unfilled slots with reassignment + reassignmentAttempts = 0 + Const MAX_ATTEMPTS As Long = 10 Do - needsReassignment = False - Dim lastTwoWeeksStart As Long - lastTwoWeeksStart = LAST_ROW_ROSTER - 13 ' Last 14 days (2 weeks) - If lastTwoWeeksStart < START_ROW Then lastTwoWeeksStart = START_ROW + ' Check for unfilled slots + Dim unfilledSlots As Long + unfilledSlots = CountUnfilledSlots(START_ROW, last_row_roster) + Debug.Print "Unfilled slots: " & unfilledSlots - ' Check if any All Days staff need reassignment - For i = 1 To aohtbl.ListRows.Count - staffName = aohtbl.DataBodyRange(i, aohtbl.ListColumns("Name").Index).Value - maxDuties = aohtbl.DataBodyRange(i, aohtbl.ListColumns("Max Duties").Index).Value - currDuties = aohtbl.DataBodyRange(i, aohtbl.ListColumns("Duties Counter").Index).Value - If UCase(aohtbl.DataBodyRange(i, aohtbl.ListColumns("Availability Type").Index).Value) <> "SPECIFIC DAYS" And currDuties < maxDuties Then - needsReassignment = True - Debug.Print "Staff " & staffName & " needs reassignment (Current: " & currDuties & ", Max: " & maxDuties & ")" - End If - Next i + ' Check for eligible staff + Dim eligibleStaffCount As Long + eligibleStaffCount = CountEligibleStaff + Debug.Print "Eligible staff (duties < max): " & eligibleStaffCount - If needsReassignment Then - ' Remove existing assignments for All Days staff in last 2 weeks and collect staff needing reassignment - Dim removedStaff() As String - ReDim removedStaff(0) - For r = lastTwoWeeksStart To LAST_ROW_ROSTER - If wsRoster.Cells(r, AOH_COL).Value <> "" And wsRoster.Cells(r, AOH_COL).Value <> "CLOSED" Then - staffName = wsRoster.Cells(r, AOH_COL).Value - For i = 1 To aohtbl.ListRows.Count - If aohtbl.DataBodyRange(i, aohtbl.ListColumns("Name").Index).Value = staffName And _ - UCase(aohtbl.DataBodyRange(i, aohtbl.ListColumns("Availability Type").Index).Value) <> "SPECIFIC DAYS" Then - wsRoster.Cells(r, AOH_COL).Value = "" - Call DecrementDutiesCounter(staffName) - Debug.Print "Removed " & staffName & " from row " & r & " (Last 2 weeks)" - ' Add to removedStaff array if not already present - Dim found As Boolean - found = False - For j = LBound(removedStaff) To UBound(removedStaff) - If removedStaff(j) = staffName Then found = True - Next j - If Not found Then - ReDim Preserve removedStaff(UBound(removedStaff) + 1) - removedStaff(UBound(removedStaff)) = staffName - End If - Exit For - End If - Next i - End If - Next r - - ' Build staff pool with only All Days staff needing reassignment (currDuties < maxDuties) - Dim staffPool() As String - ReDim staffPool(0) - For i = 1 To aohtbl.ListRows.Count + If unfilledSlots > 0 And eligibleStaffCount > 0 Then + ' Enter reassignment phase + Call ReassignAOHDuties + Else + Exit Do + End If + reassignmentAttempts = reassignmentAttempts + 1 + If reassignmentAttempts > MAX_ATTEMPTS Then + Debug.Print "Max reassignment attempts reached. Assigning remaining staff to unfilled slots." + ' Fallback: Assign all remaining eligible staff to unfilled slots + Dim eligibleStaffList As Collection + Set eligibleStaffList = New Collection + For i = 1 To aohtbl.ListRows.count staffName = aohtbl.DataBodyRange(i, aohtbl.ListColumns("Name").Index).Value - If UCase(aohtbl.DataBodyRange(i, aohtbl.ListColumns("Availability Type").Index).Value) <> "SPECIFIC DAYS" Then - maxDuties = aohtbl.DataBodyRange(i, aohtbl.ListColumns("Max Duties").Index).Value - currDuties = aohtbl.DataBodyRange(i, aohtbl.ListColumns("Duties Counter").Index).Value - If currDuties < maxDuties Then - found = False - For j = LBound(staffPool) To UBound(staffPool) - If staffPool(j) = staffName Then found = True - Next j - If Not found Then - ReDim Preserve staffPool(UBound(staffPool) + 1) - staffPool(UBound(staffPool)) = staffName - End If - End If + maxDuties = aohtbl.DataBodyRange(i, aohtbl.ListColumns("Max Duties").Index).Value + currDuties = aohtbl.DataBodyRange(i, aohtbl.ListColumns("Duties Counter").Index).Value + If UCase(aohtbl.DataBodyRange(i, aohtbl.ListColumns("Availability Type").Index).Value) <> "SPECIFIC DAYS" And _ + currDuties < maxDuties Then + eligibleStaffList.Add staffName End If Next i - ' Combine removed staff with staff pool (avoid duplicates) - For j = LBound(removedStaff) To UBound(removedStaff) - If removedStaff(j) <> "" Then - found = False - For k = LBound(staffPool) To UBound(staffPool) - If staffPool(k) = removedStaff(j) Then found = True - Next k - If Not found Then - ReDim Preserve staffPool(UBound(staffPool) + 1) - staffPool(UBound(staffPool)) = removedStaff(j) - End If + Dim unfilledSlotsList As Collection + Set unfilledSlotsList = New Collection + For r = START_ROW To last_row_roster + If wsRoster.Cells(r, DAY_COL).Value <> "Sat" And _ + wsRoster.Cells(r, AOH_COL).Value = "" And _ + UCase(Trim(wsRoster.Cells(r, VAC_COL).Value)) = "SEM TIME" Then + unfilledSlotsList.Add r End If - Next j + Next r - ' Shuffle staff pool - Dim tmpStaff() As String - If UBound(staffPool) > 0 Then - ReDim tmpStaff(1 To UBound(staffPool)) - For j = 1 To UBound(staffPool) - tmpStaff(j) = staffPool(j) - Next j - Call ShuffleArrayString(tmpStaff) + ' Assign each eligible staff to an unfilled slot + For i = 1 To eligibleStaffList.count + If i <= unfilledSlotsList.count Then + staffName = eligibleStaffList(i) + r = unfilledSlotsList(i) + wsRoster.Cells(r, AOH_COL).Value = staffName + wsRoster.Cells(r, AOH_COL).Interior.Color = vbYellow ' Highlight yellow (RGB 255, 255, 0) + Call IncrementDutiesCounter(staffName) + Debug.Print "Fallback: Assigned " & staffName & " to row " & r & " (highlighted yellow)" + End If + Next i + Exit Do + End If + Loop + + MsgBox "Duties assignment completed!", vbInformation +End Sub + +' Helper to count unfilled AOH slots +Function CountUnfilledSlots(startRow As Long, endRow As Long) As Long + Dim r As Long + Dim count As Long + count = 0 + For r = startRow To endRow + If wsRoster.Cells(r, DAY_COL).Value <> "Sat" And _ + wsRoster.Cells(r, AOH_COL).Value = "" And _ + UCase(Trim(wsRoster.Cells(r, VAC_COL).Value)) = "SEM TIME" Then + count = count + 1 + End If + Next r + CountUnfilledSlots = count +End Function + +' Helper to count eligible staff (duties < max) +Function CountEligibleStaff() As Long + Dim i As Long + Dim count As Long + count = 0 + For i = 1 To aohtbl.ListRows.count + Dim staffName As String + Dim maxDuties As Long + Dim currDuties As Long + staffName = aohtbl.DataBodyRange(i, aohtbl.ListColumns("Name").Index).Value + maxDuties = aohtbl.DataBodyRange(i, aohtbl.ListColumns("Max Duties").Index).Value + currDuties = aohtbl.DataBodyRange(i, aohtbl.ListColumns("Duties Counter").Index).Value + If UCase(aohtbl.DataBodyRange(i, aohtbl.ListColumns("Availability Type").Index).Value) <> "SPECIFIC DAYS" And _ + currDuties < maxDuties Then + count = count + 1 + End If + Next i + CountEligibleStaff = count +End Function + +' Helper to reassign AOH duties with swap logic +Sub ReassignAOHDuties() + Dim r As Long + Dim i As Long + Dim staffName As String + Dim maxDuties As Long + Dim currDuties As Long + Dim eligibleStaff As String + Dim weekStart As Long, weekEnd As Long + Dim swapCandidate As String + Dim swapRow As Long + + ' Find the first eligible staff (currDuties < maxDuties) + eligibleStaff = GetFirstEligibleStaff + If eligibleStaff = "" Then + Debug.Print "No eligible staff found for reassignment." + Exit Sub + End If + Debug.Print "Eligible staff for reassignment: " & eligibleStaff + + ' Find a week where eligibleStaff has no AOH duties + Dim hasNoDutyWeek As Boolean + hasNoDutyWeek = False + For r = START_ROW To last_row_roster + If wsRoster.Cells(r, DAY_COL).Value <> "Sat" And _ + UCase(Trim(wsRoster.Cells(r, VAC_COL).Value)) = "SEM TIME" Then + weekStart = r - (Weekday(wsRoster.Cells(r, DATE_COL).Value, vbMonday) - 1) + If weekStart < START_ROW Then weekStart = START_ROW + weekEnd = weekStart + 6 + If weekEnd >= last_row_roster Then weekEnd = last_row_roster - 1 + + If Not HasAOHDutyInWeek(eligibleStaff, weekStart, weekEnd) Then + hasNoDutyWeek = True + Debug.Print "Found week with no duty for " & eligibleStaff & ": Start = " & weekStart & ", End = " & weekEnd + Exit For End If - - ' Reassign randomly from staff pool - Dim assignedInThisPass As Boolean - assignedInThisPass = False - For r = lastTwoWeeksStart To LAST_ROW_ROSTER - If wsRoster.Cells(r, DAY_COL).Value = "Sat" Then GoTo SkipReassignDay - If wsRoster.Cells(r, AOH_COL).Value <> "" Or wsRoster.Cells(r, AOH_COL).Value = "CLOSED" Then GoTo SkipReassignDay - If UCase(Trim(wsRoster.Cells(r, VAC_COL).Value)) <> "SEM TIME" Then GoTo SkipReassignDay - - For i = 1 To UBound(tmpStaff) - staffName = tmpStaff(i) - For j = 1 To aohtbl.ListRows.Count - If aohtbl.DataBodyRange(j, aohtbl.ListColumns("Name").Index).Value = staffName And _ - UCase(aohtbl.DataBodyRange(j, aohtbl.ListColumns("Availability Type").Index).Value) <> "SPECIFIC DAYS" Then - maxDuties = aohtbl.DataBodyRange(j, aohtbl.ListColumns("Max Duties").Index).Value - currDuties = aohtbl.DataBodyRange(j, aohtbl.ListColumns("Duties Counter").Index).Value - If currDuties < maxDuties And CheckWeeklyLimit(staffName, r, START_ROW, LAST_ROW_ROSTER) Then - wsRoster.Cells(r, AOH_COL).Value = staffName - Call IncrementDutiesCounter(staffName) - Debug.Print "Reassigned All Days staff " & staffName & " to row " & r & " (Last 2 weeks)" - assignedInThisPass = True - Exit For + End If + Next r + + If Not hasNoDutyWeek Then + Debug.Print "No week found where " & eligibleStaff & " has no AOH duty." + Exit Sub + End If + + ' Loop through work all day staff to attempt swapping + For i = 1 To aohtbl.ListRows.count + swapCandidate = aohtbl.DataBodyRange(i, aohtbl.ListColumns("Name").Index).Value + If UCase(aohtbl.DataBodyRange(i, aohtbl.ListColumns("Availability Type").Index).Value) <> "SPECIFIC DAYS" Then + ' Find an existing AOH duty for swapCandidate in the identified week + For r = weekStart To weekEnd + If wsRoster.Cells(r, AOH_COL).Value = swapCandidate And _ + UCase(Trim(wsRoster.Cells(r, VAC_COL).Value)) = "SEM TIME" Then + swapRow = r + Debug.Print "Checking swap for " & swapCandidate & " at row " & swapRow + + ' Check if swapping is possible for eligibleStaff + If CheckWeeklyLimit(eligibleStaff, swapRow, START_ROW, last_row_roster) Then + ' Find another duty slot for swapCandidate (if any) + Dim otherDutyRow As Long + otherDutyRow = FindOtherDutySlot(swapCandidate, swapRow, weekStart, weekEnd) + If otherDutyRow > 0 Or (aohtbl.DataBodyRange(i, aohtbl.ListColumns("Duties Counter").Index).Value > 1) Then + ' Perform swap + ' Remove swapCandidate's duty from swapRow + wsRoster.Cells(swapRow, AOH_COL).Value = "" + Call DecrementDutiesCounter(swapCandidate) + + ' Assign eligibleStaff to swapCandidate's original slot + wsRoster.Cells(swapRow, AOH_COL).Value = eligibleStaff + Call IncrementDutiesCounter(eligibleStaff) + Debug.Print "Assigned " & eligibleStaff & " to row " & swapRow + + ' If another duty exists, move swapCandidate there; otherwise, leave unassigned + If otherDutyRow > 0 Then + wsRoster.Cells(otherDutyRow, AOH_COL).Value = swapCandidate + Call IncrementDutiesCounter(swapCandidate) + Debug.Print "Reassigned " & swapCandidate & " to row " & otherDutyRow Else - Debug.Print " Skipped " & staffName & " at row " & r & " (Limit reached or same-day conflict)" + Debug.Print "No other duty slot for " & swapCandidate & "; left unassigned" End If + Exit Sub ' Exit after successful swap + Else + Debug.Print "No other duty slot or multiple duties for " & swapCandidate & " to swap" End If - Next j - If wsRoster.Cells(r, AOH_COL).Value <> "" Then Exit For - Next i -SkipReassignDay: + Else + Debug.Print "Swap not possible: Weekly limit check failed for " & eligibleStaff + End If + End If Next r - - ' If no assignments were made in this pass, break the loop to avoid infinite cycling - If Not assignedInThisPass Then needsReassignment = False End If - Loop Until Not needsReassignment - - MsgBox "Duties assignment completed!", vbInformation + Next i End Sub +' Helper to find the first unfilled slot +Function FindFirstUnfilledSlot() As Long + Dim r As Long + For r = START_ROW To last_row_roster + If wsRoster.Cells(r, DAY_COL).Value <> "Sat" And _ + wsRoster.Cells(r, AOH_COL).Value = "" And _ + UCase(Trim(wsRoster.Cells(r, VAC_COL).Value)) = "SEM TIME" Then + FindFirstUnfilledSlot = r + Exit Function + End If + Next r + FindFirstUnfilledSlot = 0 ' No eligible slot found +End Function + +' Helper to find another duty slot for swapCandidate +Function FindOtherDutySlot(staffName As String, avoidRow As Long, weekStart As Long, weekEnd As Long) As Long + Dim r As Long + For r = weekStart To weekEnd + If r <> avoidRow And wsRoster.Cells(r, AOH_COL).Value = staffName And _ + UCase(Trim(wsRoster.Cells(r, VAC_COL).Value)) = "SEM TIME" Then + FindOtherDutySlot = r + Exit Function + End If + Next r + FindOtherDutySlot = 0 ' No other duty slot found +End Function + +' Helper to check if a staff has an AOH duty in a given week +Function HasAOHDutyInWeek(staffName As String, weekStart As Long, weekEnd As Long) As Boolean + Dim r As Long + For r = weekStart To weekEnd + If (wsRoster.Cells(r, AOH_COL).Value = staffName Or _ + wsRoster.Cells(r, SAT_AOH_COL1).Value = staffName Or _ + wsRoster.Cells(r, SAT_AOH_COL2).Value = staffName) And _ + UCase(Trim(wsRoster.Cells(r, VAC_COL).Value)) = "SEM TIME" Then + HasAOHDutyInWeek = True + Exit Function + End If + Next r + HasAOHDutyInWeek = False +End Function + +' Helper to get the first eligible staff (duties < max) +Function GetFirstEligibleStaff() As String + Dim i As Long + For i = 1 To aohtbl.ListRows.count + Dim staffName As String + Dim maxDuties As Long + Dim currDuties As Long + staffName = aohtbl.DataBodyRange(i, aohtbl.ListColumns("Name").Index).Value + maxDuties = aohtbl.DataBodyRange(i, aohtbl.ListColumns("Max Duties").Index).Value + currDuties = aohtbl.DataBodyRange(i, aohtbl.ListColumns("Duties Counter").Index).Value + If UCase(aohtbl.DataBodyRange(i, aohtbl.ListColumns("Availability Type").Index).Value) <> "SPECIFIC DAYS" And _ + currDuties < maxDuties Then + GetFirstEligibleStaff = staffName + Exit Function + End If + Next i + GetFirstEligibleStaff = "" +End Function + ' Helper to shuffle array Sub ShuffleArray(arr() As Long) Dim i As Long, j As Long, tmp As Long @@ -267,42 +401,22 @@ Sub ShuffleArray(arr() As Long) arr(j) = tmp Next i End Sub -' Helper to shuffle array of strings -Sub ShuffleArrayString(arr() As String) - Dim i As Long, j As Long, tmp As String - Randomize - For i = UBound(arr) To LBound(arr) + 1 Step -1 - j = Int(Rnd() * (i - LBound(arr) + 1)) + LBound(arr) - tmp = arr(i) - arr(i) = arr(j) - arr(j) = tmp - Next i -End Sub Function GetEligibleRows(totalDays As Long, workDays As Variant) As Collection Dim eligibleRows As New Collection Dim r As Long, j As Long Dim dayName As String - 'Debug.Print "=== Checking Eligible Rows ===" - 'Debug.Print "WorkDays:" - For j = LBound(workDays) To UBound(workDays) - 'Debug.Print "[" & j & "]: " & workDays(j) - Next j - - For r = START_ROW To LAST_ROW_ROSTER + For r = START_ROW To last_row_roster dayName = Trim(wsRoster.Cells(r, DAY_COL).Value) - 'Debug.Print "Row " & r & ": " & dayName ' Skip if already filled If Not IsEmpty(wsRoster.Cells(r, AOH_COL)) Then - 'Debug.Print " -> Skipped (Already Assigned)" GoTo SkipRow End If ' Check if the day is within sem time If UCase(Trim(wsRoster.Cells(r, VAC_COL).Value)) <> "SEM TIME" Then - 'Debug.Print " -> Skipped (Not Sem Time)" GoTo SkipRow End If @@ -310,30 +424,22 @@ Function GetEligibleRows(totalDays As Long, workDays As Variant) As Collection For j = LBound(workDays) To UBound(workDays) If dayName = workDays(j) Then eligibleRows.Add r - 'Debug.Print " -> Added (Matched with " & workDays(j) & ")" Exit For End If Next j SkipRow: Next r - Debug.Print "Total Eligible: " & eligibleRows.Count + Debug.Print "Total Eligible: " & eligibleRows.count Set GetEligibleRows = eligibleRows End Function Sub IncrementDutiesCounter(staffName As String) Dim rowIdx As Variant Dim foundCell As Range - - ' Search for the staff name - Set foundCell = aohtbl.ListColumns("Name").DataBodyRange.Find( _ - What:=staffName, LookIn:=xlValues, LookAt:=xlWhole) - + Set foundCell = aohtbl.ListColumns("Name").DataBodyRange.Find(What:=staffName, LookIn:=xlValues, LookAt:=xlWhole) If Not foundCell Is Nothing Then - ' Get relative row index in the table rowIdx = foundCell.row - aohtbl.HeaderRowRange.row - - ' Increment Duties Counter With aohtbl.ListRows(rowIdx).Range.Cells(aohtbl.ListColumns("Duties Counter").Index) .Value = .Value + 1 End With @@ -345,19 +451,12 @@ End Sub Sub DecrementDutiesCounter(staffName As String) Dim rowIdx As Variant Dim foundCell As Range - - ' Search for the staff name - Set foundCell = aohtbl.ListColumns("Name").DataBodyRange.Find( _ - What:=staffName, LookIn:=xlValues, LookAt:=xlWhole) - + Set foundCell = aohtbl.ListColumns("Name").DataBodyRange.Find(What:=staffName, LookIn:=xlValues, LookAt:=xlWhole) If Not foundCell Is Nothing Then - ' Get relative row index in the table rowIdx = foundCell.row - aohtbl.HeaderRowRange.row - - ' Decrement Duties Counter With aohtbl.ListRows(rowIdx).Range.Cells(aohtbl.ListColumns("Duties Counter").Index) .Value = .Value - 1 - If .Value < 0 Then .Value = 0 ' Prevent negative values + If .Value < 0 Then .Value = 0 End With Else MsgBox "Staff '" & staffName & "' not found in table.", vbExclamation @@ -370,17 +469,39 @@ Function CheckWeeklyLimit(staffName As String, rowNum As Long, startRow As Long, Dim weekStart As Long Dim weekEnd As Long Dim dutyCount As Long + Dim dateValue As Variant Set ws = wsRoster - weekStart = rowNum - (Weekday(ws.Cells(rowNum, DATE_COL).Value, vbMonday) - 1) + + ' Validate rowNum + If rowNum = 0 Or rowNum < startRow Or rowNum > endRow Then + Debug.Print "Invalid rowNum " & rowNum & ". Skipping weekly limit check." + CheckWeeklyLimit = False + Exit Function + End If + + ' Validate date + dateValue = ws.Cells(rowNum, DATE_COL).Value + If IsEmpty(dateValue) Or Not IsDate(dateValue) Then + Debug.Print "Invalid date at row " & rowNum & ", column " & DATE_COL & ". Skipping weekly limit check." + CheckWeeklyLimit = False + Exit Function + End If + + Debug.Print "Weekday: " & Weekday(dateValue, vbMonday) + weekStart = rowNum - (Weekday(dateValue, vbMonday) - 1) If weekStart < startRow Then weekStart = startRow weekEnd = weekStart + 6 If weekEnd >= endRow Then weekEnd = endRow - 1 + Debug.Print "Here i am now" & weekStart & weekEnd Debug.Print "Row " & rowNum & ": Week Start = " & weekStart & ", End = " & weekEnd + dutyCount = 0 For i = weekStart To weekEnd - If i >= startRow And i < endRow And (ws.Cells(i, AOH_COL).Value = staffName Or ws.Cells(i, SAT_AOH_COL1).Value = staffName Or ws.Cells(i, SAT_AOH_COL2).Value = staffName) And UCase(Trim(ws.Cells(i, VAC_COL).Value)) = "SEM TIME" Then + If i >= startRow And i < endRow And (ws.Cells(i, AOH_COL).Value = staffName Or _ + ws.Cells(i, SAT_AOH_COL1).Value = staffName Or ws.Cells(i, SAT_AOH_COL2).Value = staffName) And _ + UCase(Trim(ws.Cells(i, VAC_COL).Value)) = "SEM TIME" Then dutyCount = dutyCount + 1 If dutyCount >= 1 Then CheckWeeklyLimit = False @@ -391,3 +512,5 @@ Function CheckWeeklyLimit(staffName As String, rowNum As Long, startRow As Long, CheckWeeklyLimit = True End Function + +