From 76282fa19588c391880fe25af624353b4b8f7373 Mon Sep 17 00:00:00 2001 From: Casielim Date: Sat, 5 Jul 2025 16:53:22 +0800 Subject: [PATCH 1/9] Assign morning staff --- .../AssignMorningDuties.bas | 184 ++++++++++++++++++ 1 file changed, 184 insertions(+) create mode 100644 VBA/VBA-Code_By_Modules/AssignMorningDuties.bas diff --git a/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas b/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas new file mode 100644 index 0000000..abfc9df --- /dev/null +++ b/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas @@ -0,0 +1,184 @@ +Attribute VB_Name = "AssignMorningDuties" +'declare worksheet and table + Private wsRosterCopy As Worksheet + Private wsPersonnel As Worksheet + Private wsSettings As Worksheet + Private morningtbl As ListObject + Private spectbl As ListObject + +'declare roster column number + 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 START_ROW As Long = 6 + +Sub AssignMorningDuties() + Set wsRosterCopy = Sheets("MasterCopy (2)") + Set wsSettings = Sheets("Settings") + Set wsPersonnel = Sheets("PersonnelList Copy") + Set morningtbl = wsPersonnel.ListObjects("MorningMainList") + Set spectbl = wsPersonnel.ListObjects("MorningSpecificDaysWorkingStaff") + + 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 candidates() As String + Dim staffName As String + Dim workDays As Variant + Dim dictAssigned As Object, dictMax As Object + + totalDays = wsRosterCopy.Range(wsRosterCopy.Cells(START_ROW, DATE_COL), wsRosterCopy.Cells(186, DATE_COL)).Rows.Count + + Set dictAssigned = CreateObject("Scripting.Dictionary") + Set dictMax = CreateObject("Scripting.Dictionary") + + ' Clear morning column assignments + wsRosterCopy.Range(wsRosterCopy.Cells(START_ROW, MOR_COL), wsRosterCopy.Cells(186, MOR_COL)).Interior.ColorIndex = xlNone + + ' Step 1: Assign Specific Days Staff + For i = 1 To spectbl.ListRows.Count + staffName = spectbl.DataBodyRange(i, spectbl.ListColumns("Name").Index).Value + Debug.Print 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 morningtbl.ListRows.Count + If morningtbl.DataBodyRange(r, morningtbl.ListColumns("Name").Index).Value = staffName Then + maxDuties = morningtbl.DataBodyRange(r, morningtbl.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 + For j = 1 To Application.Min(maxDuties, eligibleRows.Count) + wsRosterCopy.Cells(tmpRows(j), MOR_COL).Value = staffName + dictAssigned(staffName) = dictAssigned(staffName) + 1 + + ' increment the Duties Counter + Call IncrementDutiesCounter(staffName) + Next j + Next i + + ' Step 2: Assign All Days Staff + For r = START_ROW To totalDays + For i = 1 To morningtbl.ListRows.Count + staffName = morningtbl.DataBodyRange(i, morningtbl.ListColumns("Name").Index).Value + If UCase(morningtbl.DataBodyRange(i, morningtbl.ListColumns("Availability Type").Index).Value) = "SPECIFIC DAYS" Then + GoTo SkipStaff + End If + + maxDuties = morningtbl.DataBodyRange(i, morningtbl.ListColumns("Max Duties").Index).Value + currDuties = morningtbl.DataBodyRange(i, morningtbl.ListColumns("Duties Counter").Index).Value + 'check if the staff already reach his max duties + If currDuties >= maxDuties Then GoTo SkipStaff + + ' Assign from top + If wsRoster.Cells(r, MOR_COL).Value = "" Then + wsRoster.Cells(r, MOR_COL).Value = staffName + Call IncrementDutiesCounter(staffName) + Exit For + End If + +SkipStaff: + Next i + 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 = Array(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 totalDays + dayName = Trim(wsRosterCopy.Cells(r, DAY_COL).Value) + ' Debug: show what day we are checking + Debug.Print "Row " & r & ": " & dayName + + ' Skip if already filled + If Not IsEmpty(wsRosterCopy.Cells(r, MOR_COL)) Then + Debug.Print " -> Skipped (Already Assigned)" + 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 = morningtbl.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 - morningtbl.HeaderRowRange.Row + + ' Increment Duties Counter + With morningtbl.ListRows(rowIdx).Range.Cells(morningtbl.ListColumns("Duties Counter").Index) + .Value = .Value + 1 + End With + Else + MsgBox "Staff '" & staffName & "' not found in table.", vbExclamation + End If +End Sub + + From 74d046fd173d7e54bd4bf18b5063e7c4d4dbb551 Mon Sep 17 00:00:00 2001 From: Casielim Date: Sat, 5 Jul 2025 17:01:27 +0800 Subject: [PATCH 2/9] Debug naming error --- VBA/VBA-Code_By_Modules/AssignMorningDuties.bas | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas b/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas index abfc9df..a0cf072 100644 --- a/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas +++ b/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas @@ -97,8 +97,8 @@ Sub AssignMorningDuties() If currDuties >= maxDuties Then GoTo SkipStaff ' Assign from top - If wsRoster.Cells(r, MOR_COL).Value = "" Then - wsRoster.Cells(r, MOR_COL).Value = staffName + If wsRosterCopy.Cells(r, MOR_COL).Value = "" Then + wsRosterCopy.Cells(r, MOR_COL).Value = staffName Call IncrementDutiesCounter(staffName) Exit For End If @@ -116,7 +116,7 @@ Sub ShuffleArray(arr() As Long) Randomize For i = UBound(arr) To LBound(arr) + 1 Step -1 j = Int(Rnd() * (i - LBound(arr) + 1)) + LBound(arr) - tmp = Array(i) + tmp = arr(i) arr(i) = arr(j) arr(j) = tmp Next i From 4f9a209b65ebbdfce86ee3580804d65362653d09 Mon Sep 17 00:00:00 2001 From: Casielim Date: Sun, 6 Jul 2025 00:54:11 +0800 Subject: [PATCH 3/9] Debug last row of roster --- VBA/VBA-Code_By_Modules/AssignMorningDuties.bas | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas b/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas index a0cf072..eb27f38 100644 --- a/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas +++ b/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas @@ -15,6 +15,7 @@ Attribute VB_Name = "AssignMorningDuties" 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 AssignMorningDuties() @@ -40,7 +41,7 @@ Sub AssignMorningDuties() Set dictMax = CreateObject("Scripting.Dictionary") ' Clear morning column assignments - wsRosterCopy.Range(wsRosterCopy.Cells(START_ROW, MOR_COL), wsRosterCopy.Cells(186, MOR_COL)).Interior.ColorIndex = xlNone + 'wsRosterCopy.Range(wsRosterCopy.Cells(START_ROW, MOR_COL), wsRosterCopy.Cells(186, MOR_COL)).Interior.ColorIndex = xlNone ' Step 1: Assign Specific Days Staff For i = 1 To spectbl.ListRows.Count @@ -84,7 +85,9 @@ Sub AssignMorningDuties() Next i ' Step 2: Assign All Days Staff - For r = START_ROW To totalDays + For r = START_ROW To 186 + If wsRosterCopy.Cells(r, DAY_COL).Value = "Sat" Then GoTo SkipDay + If wsRosterCopy.Cells(r, MOR_COL).Value = "CLOSED" Then GoTo SkipDay For i = 1 To morningtbl.ListRows.Count staffName = morningtbl.DataBodyRange(i, morningtbl.ListColumns("Name").Index).Value If UCase(morningtbl.DataBodyRange(i, morningtbl.ListColumns("Availability Type").Index).Value) = "SPECIFIC DAYS" Then @@ -105,7 +108,9 @@ Sub AssignMorningDuties() SkipStaff: Next i - Next r + +SkipDay: + Next r MsgBox "Duties assignment completed!", vbInformation End Sub @@ -134,7 +139,7 @@ Function GetEligibleRows(totalDays As Long, workDays As Variant) As Collection Next j - For r = START_ROW To totalDays + For r = START_ROW To 186 dayName = Trim(wsRosterCopy.Cells(r, DAY_COL).Value) ' Debug: show what day we are checking Debug.Print "Row " & r & ": " & dayName From 477307710fc612b8097e81eda19b7062eea82f5b Mon Sep 17 00:00:00 2001 From: Casielim Date: Mon, 7 Jul 2025 13:40:02 +0800 Subject: [PATCH 4/9] Change "PersonnelList Copy" to "Morning PersonnelList" --- VBA/VBA-Code_By_Modules/AssignMorningDuties.bas | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas b/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas index eb27f38..33e2aca 100644 --- a/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas +++ b/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas @@ -21,7 +21,7 @@ Attribute VB_Name = "AssignMorningDuties" Sub AssignMorningDuties() Set wsRosterCopy = Sheets("MasterCopy (2)") Set wsSettings = Sheets("Settings") - Set wsPersonnel = Sheets("PersonnelList Copy") + Set wsPersonnel = Sheets("Morning PersonnelList") Set morningtbl = wsPersonnel.ListObjects("MorningMainList") Set spectbl = wsPersonnel.ListObjects("MorningSpecificDaysWorkingStaff") @@ -33,15 +33,8 @@ Sub AssignMorningDuties() Dim candidates() As String Dim staffName As String Dim workDays As Variant - Dim dictAssigned As Object, dictMax As Object totalDays = wsRosterCopy.Range(wsRosterCopy.Cells(START_ROW, DATE_COL), wsRosterCopy.Cells(186, DATE_COL)).Rows.Count - - Set dictAssigned = CreateObject("Scripting.Dictionary") - Set dictMax = CreateObject("Scripting.Dictionary") - - ' Clear morning column assignments - 'wsRosterCopy.Range(wsRosterCopy.Cells(START_ROW, MOR_COL), wsRosterCopy.Cells(186, MOR_COL)).Interior.ColorIndex = xlNone ' Step 1: Assign Specific Days Staff For i = 1 To spectbl.ListRows.Count @@ -77,7 +70,6 @@ Sub AssignMorningDuties() ' Assign staff For j = 1 To Application.Min(maxDuties, eligibleRows.Count) wsRosterCopy.Cells(tmpRows(j), MOR_COL).Value = staffName - dictAssigned(staffName) = dictAssigned(staffName) + 1 ' increment the Duties Counter Call IncrementDutiesCounter(staffName) From dab9bb8e9ede324cc7bacd61fae828595950719f Mon Sep 17 00:00:00 2001 From: Casielim Date: Tue, 8 Jul 2025 22:57:49 +0800 Subject: [PATCH 5/9] Use global variable LAST_ROW_ROSTER --- VBA/VBA-Code_By_Modules/AssignMorningDuties.bas | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas b/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas index 33e2aca..099e914 100644 --- a/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas +++ b/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas @@ -34,7 +34,7 @@ Sub AssignMorningDuties() 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 For i = 1 To spectbl.ListRows.Count @@ -77,7 +77,7 @@ Sub AssignMorningDuties() Next i ' Step 2: Assign All Days Staff - 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, MOR_COL).Value = "CLOSED" Then GoTo SkipDay For i = 1 To morningtbl.ListRows.Count @@ -131,7 +131,7 @@ Function GetEligibleRows(totalDays As Long, workDays As Variant) As Collection 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: show what day we are checking Debug.Print "Row " & r & ": " & dayName From 10213f48a77c280bedd3a65e0239ee49e4a17c6f Mon Sep 17 00:00:00 2001 From: Casielim Date: Tue, 8 Jul 2025 23:45:01 +0800 Subject: [PATCH 6/9] Add restriction to prevent working more than 1 slot on the same day --- .../AssignMorningDuties.bas | 34 +++++++++++++++---- 1 file changed, 28 insertions(+), 6 deletions(-) diff --git a/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas b/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas index 099e914..5598aea 100644 --- a/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas +++ b/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas @@ -68,11 +68,17 @@ Sub AssignMorningDuties() Call ShuffleArray(tmpRows) ' Assign staff - For j = 1 To Application.Min(maxDuties, eligibleRows.Count) - wsRosterCopy.Cells(tmpRows(j), MOR_COL).Value = staffName - - ' increment the Duties Counter - Call IncrementDutiesCounter(staffName) + Dim assignedCount As Long + assignedCount = 0 + + For j = 1 To eligibleRows.Count + If assignedCount >= maxDuties Then Exit For + + If Not IsWorkingOnSameDay(tmpRows(j), staffName) Then + wsRosterCopy.Cells(tmpRows(j), MOR_COL).Value = staffName + Call IncrementDutiesCounter(staffName) + assignedCount = assignedCount + 1 + End If Next j Next i @@ -90,6 +96,7 @@ Sub AssignMorningDuties() currDuties = morningtbl.DataBodyRange(i, morningtbl.ListColumns("Duties Counter").Index).Value 'check if the staff already reach his max duties If currDuties >= maxDuties Then GoTo SkipStaff + If IsWorkingOnSameDay(r, staffName) Then GoTo SkipStaff ' Assign from top If wsRosterCopy.Cells(r, MOR_COL).Value = "" Then @@ -167,7 +174,7 @@ Sub IncrementDutiesCounter(staffName As String) If Not foundCell Is Nothing Then ' Get relative row index in the table - rowIdx = foundCell.Row - morningtbl.HeaderRowRange.Row + rowIdx = foundCell.row - morningtbl.HeaderRowRange.row ' Increment Duties Counter With morningtbl.ListRows(rowIdx).Range.Cells(morningtbl.ListColumns("Duties Counter").Index) @@ -178,4 +185,19 @@ Sub IncrementDutiesCounter(staffName As String) End If End Sub +Function IsWorkingOnSameDay(row As Long, staffName As String) As Boolean + If wsRosterCopy.Cells(row, AFT_COL).Value = staffName Then + IsWorkingOnSameDay = True + Exit Function + End If + + If wsRosterCopy.Cells(row, AOH_COL).Value = staffName Then + IsWorkingOnSameDay = True + Exit Function + End If + + IsWorkingOnSameDay = False + +End Function + From 5f1170d49a0f58cb6b5926d3655fb3b32a98c550 Mon Sep 17 00:00:00 2001 From: Casielim Date: Fri, 18 Jul 2025 14:15:23 +0800 Subject: [PATCH 7/9] Implement reassignment --- .../AssignMorningDuties.bas | 180 +++++++++++++++++- 1 file changed, 170 insertions(+), 10 deletions(-) diff --git a/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas b/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas index 5598aea..d632c8c 100644 --- a/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas +++ b/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas @@ -93,14 +93,15 @@ Sub AssignMorningDuties() End If maxDuties = morningtbl.DataBodyRange(i, morningtbl.ListColumns("Max Duties").Index).Value + Dim currDuties As Long currDuties = morningtbl.DataBodyRange(i, morningtbl.ListColumns("Duties Counter").Index).Value - 'check if the staff already reach his max duties + ' Check if the staff already reached his max duties If currDuties >= maxDuties Then GoTo SkipStaff If IsWorkingOnSameDay(r, staffName) Then GoTo SkipStaff ' Assign from top - If wsRosterCopy.Cells(r, MOR_COL).Value = "" Then - wsRosterCopy.Cells(r, MOR_COL).Value = staffName + If wsRoster.Cells(r, MOR_COL).Value = "" Then + wsRoster.Cells(r, MOR_COL).Value = staffName Call IncrementDutiesCounter(staffName) Exit For End If @@ -111,6 +112,134 @@ 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 morningtbl.ListRows.Count + staffName = morningtbl.DataBodyRange(i, morningtbl.ListColumns("Name").Index).Value + maxDuties = morningtbl.DataBodyRange(i, morningtbl.ListColumns("Max Duties").Index).Value + currDuties = morningtbl.DataBodyRange(i, morningtbl.ListColumns("Duties Counter").Index).Value + If UCase(morningtbl.DataBodyRange(i, morningtbl.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, MOR_COL).Value <> "" And wsRoster.Cells(r, MOR_COL).Value <> "CLOSED" Then + staffName = wsRoster.Cells(r, MOR_COL).Value + For i = 1 To morningtbl.ListRows.Count + If morningtbl.DataBodyRange(i, morningtbl.ListColumns("Name").Index).Value = staffName And _ + UCase(morningtbl.DataBodyRange(i, morningtbl.ListColumns("Availability Type").Index).Value) <> "SPECIFIC DAYS" Then + wsRoster.Cells(r, MOR_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 morningtbl.ListRows.Count + staffName = morningtbl.DataBodyRange(i, morningtbl.ListColumns("Name").Index).Value + If UCase(morningtbl.DataBodyRange(i, morningtbl.ListColumns("Availability Type").Index).Value) <> "SPECIFIC DAYS" Then + maxDuties = morningtbl.DataBodyRange(i, morningtbl.ListColumns("Max Duties").Index).Value + currDuties = morningtbl.DataBodyRange(i, morningtbl.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, MOR_COL).Value <> "" Or wsRoster.Cells(r, MOR_COL).Value = "CLOSED" Then GoTo SkipReassignDay + + For i = 1 To UBound(tmpStaff) + staffName = tmpStaff(i) + For j = 1 To morningtbl.ListRows.Count + If morningtbl.DataBodyRange(j, morningtbl.ListColumns("Name").Index).Value = staffName And _ + UCase(morningtbl.DataBodyRange(j, morningtbl.ListColumns("Availability Type").Index).Value) <> "SPECIFIC DAYS" Then + maxDuties = morningtbl.DataBodyRange(j, morningtbl.ListColumns("Max Duties").Index).Value + currDuties = morningtbl.DataBodyRange(j, morningtbl.ListColumns("Duties Counter").Index).Value + If currDuties < maxDuties And Not IsWorkingOnSameDay(r, staffName) Then + wsRoster.Cells(r, MOR_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, MOR_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 @@ -126,6 +255,18 @@ Sub ShuffleArray(arr() As Long) 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 @@ -137,14 +278,13 @@ Function GetEligibleRows(totalDays As Long, workDays As Variant) As Collection Debug.Print "[" & j & "]: " & workDays(j) Next j - For r = START_ROW To LAST_ROW_ROSTER - dayName = Trim(wsRosterCopy.Cells(r, DAY_COL).Value) + dayName = Trim(wsRoster.Cells(r, DAY_COL).Value) ' Debug: show what day we are checking Debug.Print "Row " & r & ": " & dayName ' Skip if already filled - If Not IsEmpty(wsRosterCopy.Cells(r, MOR_COL)) Then + If Not IsEmpty(wsRoster.Cells(r, MOR_COL)) Then Debug.Print " -> Skipped (Already Assigned)" GoTo SkipRow End If @@ -185,19 +325,39 @@ 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 = morningtbl.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 - morningtbl.HeaderRowRange.row + + ' Decrement Duties Counter + With morningtbl.ListRows(rowIdx).Range.Cells(morningtbl.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 IsWorkingOnSameDay(row As Long, staffName As String) As Boolean - If wsRosterCopy.Cells(row, AFT_COL).Value = staffName Then + If wsRoster.Cells(row, AFT_COL).Value = staffName Then IsWorkingOnSameDay = True Exit Function End If - If wsRosterCopy.Cells(row, AOH_COL).Value = staffName Then + If wsRoster.Cells(row, AOH_COL).Value = staffName Then IsWorkingOnSameDay = True Exit Function End If IsWorkingOnSameDay = False - End Function - From e52f640fd39509c6ad1d38dddcb28ca7baede93f Mon Sep 17 00:00:00 2001 From: Casielim Date: Fri, 18 Jul 2025 14:15:50 +0800 Subject: [PATCH 8/9] Make column variables public --- .../AssignMorningDuties.bas | 35 +++++++------------ 1 file changed, 12 insertions(+), 23 deletions(-) diff --git a/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas b/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas index d632c8c..562c510 100644 --- a/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas +++ b/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas @@ -1,25 +1,13 @@ Attribute VB_Name = "AssignMorningDuties" -'declare worksheet and table - Private wsRosterCopy As Worksheet - Private wsPersonnel As Worksheet - Private wsSettings As Worksheet - Private morningtbl As ListObject - Private spectbl As ListObject - -'declare roster column number - 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 +' Declare worksheet and table +Private wsRoster As Worksheet +Private wsPersonnel As Worksheet +Private wsSettings As Worksheet +Private morningtbl As ListObject +Private spectbl As ListObject Sub AssignMorningDuties() - Set wsRosterCopy = Sheets("MasterCopy (2)") + Set wsRoster = Sheets("MasterCopy (2)") Set wsSettings = Sheets("Settings") Set wsPersonnel = Sheets("Morning PersonnelList") Set morningtbl = wsPersonnel.ListObjects("MorningMainList") @@ -34,7 +22,8 @@ Sub AssignMorningDuties() 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 + Debug.Print "morning assignment starts here" ' Step 1: Assign Specific Days Staff For i = 1 To spectbl.ListRows.Count @@ -75,7 +64,7 @@ Sub AssignMorningDuties() If assignedCount >= maxDuties Then Exit For If Not IsWorkingOnSameDay(tmpRows(j), staffName) Then - wsRosterCopy.Cells(tmpRows(j), MOR_COL).Value = staffName + wsRoster.Cells(tmpRows(j), MOR_COL).Value = staffName Call IncrementDutiesCounter(staffName) assignedCount = assignedCount + 1 End If @@ -84,8 +73,8 @@ Sub AssignMorningDuties() ' Step 2: Assign All Days Staff For r = START_ROW To LAST_ROW_ROSTER - If wsRosterCopy.Cells(r, DAY_COL).Value = "Sat" Then GoTo SkipDay - If wsRosterCopy.Cells(r, MOR_COL).Value = "CLOSED" Then GoTo SkipDay + If wsRoster.Cells(r, DAY_COL).Value = "Sat" Then GoTo SkipDay + If wsRoster.Cells(r, MOR_COL).Value = "CLOSED" Then GoTo SkipDay For i = 1 To morningtbl.ListRows.Count staffName = morningtbl.DataBodyRange(i, morningtbl.ListColumns("Name").Index).Value If UCase(morningtbl.DataBodyRange(i, morningtbl.ListColumns("Availability Type").Index).Value) = "SPECIFIC DAYS" Then From 4e71dba7ec680c9934749969e31f6f856a4d38a8 Mon Sep 17 00:00:00 2001 From: Casielim Date: Thu, 31 Jul 2025 22:34:41 +0800 Subject: [PATCH 9/9] Set reassignment --- .../AssignMorningDuties.bas | 332 ++++++++++-------- 1 file changed, 186 insertions(+), 146 deletions(-) diff --git a/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas b/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas index 562c510..5837d5b 100644 --- a/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas +++ b/VBA/VBA-Code_By_Modules/AssignMorningDuties.bas @@ -1,13 +1,13 @@ Attribute VB_Name = "AssignMorningDuties" ' Declare worksheet and table Private wsRoster As Worksheet -Private wsPersonnel As Worksheet Private wsSettings As Worksheet +Private wsPersonnel As Worksheet Private morningtbl As ListObject Private spectbl As ListObject Sub AssignMorningDuties() - Set wsRoster = Sheets("MasterCopy (2)") + Set wsRoster = Sheets("Roster") Set wsSettings = Sheets("Settings") Set wsPersonnel = Sheets("Morning PersonnelList") Set morningtbl = wsPersonnel.ListObjects("MorningMainList") @@ -21,12 +21,16 @@ Sub AssignMorningDuties() Dim candidates() As String Dim staffName As String Dim workDays As Variant + Dim eligibleRows As Collection + Dim tmpRows() As Long + Dim assignedCount As Long + Dim reassignmentAttempts As Long - totalDays = wsRoster.Range(wsRoster.Cells(START_ROW, DATE_COL), wsRoster.Cells(LAST_ROW_ROSTER, DATE_COL)).Rows.Count - Debug.Print "morning assignment starts here" + totalDays = wsRoster.Range(wsRoster.Cells(START_ROW, DATE_COL), wsRoster.Cells(last_row_roster, DATE_COL)).Rows.count + Debug.Print "Morning assignment starts here" ' Step 1: Assign Specific Days Staff - 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 staffName workDays = Split(spectbl.DataBodyRange(i, spectbl.ListColumns("Working Days").Index).Value, ",") @@ -37,7 +41,7 @@ Sub AssignMorningDuties() Next j ' Get max duties for this staff from MorningMainList - For r = 1 To morningtbl.ListRows.Count + For r = 1 To morningtbl.ListRows.count If morningtbl.DataBodyRange(r, morningtbl.ListColumns("Name").Index).Value = staffName Then maxDuties = morningtbl.DataBodyRange(r, morningtbl.ListColumns("Max Duties").Index).Value Exit For @@ -45,24 +49,19 @@ Sub AssignMorningDuties() 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 - Dim assignedCount As Long assignedCount = 0 - - For j = 1 To eligibleRows.Count + For j = 1 To eligibleRows.count If assignedCount >= maxDuties Then Exit For - If Not IsWorkingOnSameDay(tmpRows(j), staffName) Then wsRoster.Cells(tmpRows(j), MOR_COL).Value = staffName Call IncrementDutiesCounter(staffName) @@ -72,10 +71,10 @@ Sub AssignMorningDuties() Next i ' Step 2: Assign All Days Staff - 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, MOR_COL).Value = "CLOSED" Then GoTo SkipDay - For i = 1 To morningtbl.ListRows.Count + For i = 1 To morningtbl.ListRows.count staffName = morningtbl.DataBodyRange(i, morningtbl.ListColumns("Name").Index).Value If UCase(morningtbl.DataBodyRange(i, morningtbl.ListColumns("Availability Type").Index).Value) = "SPECIFIC DAYS" Then GoTo SkipStaff @@ -101,152 +100,172 @@ SkipStaff: SkipDay: Next r - ' Step 3: Reassign All Days Staff for last 2 weeks with random assignment - Dim needsReassignment As Boolean + ' Step 3: Reassign for unfilled slots + 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 morningtbl.ListRows.Count - staffName = morningtbl.DataBodyRange(i, morningtbl.ListColumns("Name").Index).Value - maxDuties = morningtbl.DataBodyRange(i, morningtbl.ListColumns("Max Duties").Index).Value - currDuties = morningtbl.DataBodyRange(i, morningtbl.ListColumns("Duties Counter").Index).Value - If UCase(morningtbl.DataBodyRange(i, morningtbl.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, MOR_COL).Value <> "" And wsRoster.Cells(r, MOR_COL).Value <> "CLOSED" Then - staffName = wsRoster.Cells(r, MOR_COL).Value - For i = 1 To morningtbl.ListRows.Count - If morningtbl.DataBodyRange(i, morningtbl.ListColumns("Name").Index).Value = staffName And _ - UCase(morningtbl.DataBodyRange(i, morningtbl.ListColumns("Availability Type").Index).Value) <> "SPECIFIC DAYS" Then - wsRoster.Cells(r, MOR_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 morningtbl.ListRows.Count + If unfilledSlots > 0 And eligibleStaffCount > 0 Then + ' Enter reassignment phase + Call ReassignMorningDuties + 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 morningtbl.ListRows.count staffName = morningtbl.DataBodyRange(i, morningtbl.ListColumns("Name").Index).Value - If UCase(morningtbl.DataBodyRange(i, morningtbl.ListColumns("Availability Type").Index).Value) <> "SPECIFIC DAYS" Then - maxDuties = morningtbl.DataBodyRange(i, morningtbl.ListColumns("Max Duties").Index).Value - currDuties = morningtbl.DataBodyRange(i, morningtbl.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 = morningtbl.DataBodyRange(i, morningtbl.ListColumns("Max Duties").Index).Value + currDuties = morningtbl.DataBodyRange(i, morningtbl.ListColumns("Duties Counter").Index).Value + If UCase(morningtbl.DataBodyRange(i, morningtbl.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, MOR_COL).Value = "" Then + unfilledSlotsList.Add r 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, MOR_COL).Value <> "" Or wsRoster.Cells(r, MOR_COL).Value = "CLOSED" Then GoTo SkipReassignDay - - For i = 1 To UBound(tmpStaff) - staffName = tmpStaff(i) - For j = 1 To morningtbl.ListRows.Count - If morningtbl.DataBodyRange(j, morningtbl.ListColumns("Name").Index).Value = staffName And _ - UCase(morningtbl.DataBodyRange(j, morningtbl.ListColumns("Availability Type").Index).Value) <> "SPECIFIC DAYS" Then - maxDuties = morningtbl.DataBodyRange(j, morningtbl.ListColumns("Max Duties").Index).Value - currDuties = morningtbl.DataBodyRange(j, morningtbl.ListColumns("Duties Counter").Index).Value - If currDuties < maxDuties And Not IsWorkingOnSameDay(r, staffName) Then - wsRoster.Cells(r, MOR_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, MOR_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 + ' 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) + If Not IsWorkingOnSameDay(r, staffName) Then + wsRoster.Cells(r, MOR_COL).Value = staffName + wsRoster.Cells(r, MOR_COL).Interior.Color = vbYellow ' Highlight yellow (RGB 255, 255, 0) + Call IncrementDutiesCounter(staffName) + Debug.Print "Fallback: Assigned " & staffName & " to row " & r & " (highlighted yellow)" + Else + Debug.Print "Fallback: Skipped " & staffName & " at row " & r & " due to AOH/AFT conflict" + End If + End If + Next i + Exit Do End If - Loop Until Not needsReassignment + Loop 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 +' Helper to count unfilled morning 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, MOR_COL).Value = "" 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 morningtbl.ListRows.count + Dim staffName As String + Dim maxDuties As Long + Dim currDuties As Long + staffName = morningtbl.DataBodyRange(i, morningtbl.ListColumns("Name").Index).Value + maxDuties = morningtbl.DataBodyRange(i, morningtbl.ListColumns("Max Duties").Index).Value + currDuties = morningtbl.DataBodyRange(i, morningtbl.ListColumns("Duties Counter").Index).Value + If UCase(morningtbl.DataBodyRange(i, morningtbl.ListColumns("Availability Type").Index).Value) <> "SPECIFIC DAYS" And _ + currDuties < maxDuties Then + count = count + 1 + End If Next i + CountEligibleStaff = count +End Function +Sub ReassignMorningDuties() + 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 swapCandidate As String + Dim emptyRow As Long ' The empty original slot where eligibleStaff couldn't be assigned + + ' Find the first eligible staff (currDuties < maxDuties) + eligibleStaff = GetFirstEligibleStaff + If eligibleStaff = "" Then + Debug.Print "No eligible staff found for Morning reassignment." + Exit Sub + End If + Debug.Print "Eligible staff for Morning reassignment: " & eligibleStaff + + ' Assume emptyRow is determined earlier (e.g., the last unfilled slot) + emptyRow = FindLastUnfilledSlot(START_ROW, last_row_roster) + If emptyRow = 0 Then Exit Sub ' No empty slot to reassign + + ' Loop through all rows to find a swap opportunity + For r = START_ROW To last_row_roster + If wsRoster.Cells(r, DAY_COL).Value = "Sat" Or _ + wsRoster.Cells(r, MOR_COL).Value = "CLOSED" Or _ + wsRoster.Cells(r, MOR_COL).Value = "" Then + GoTo NextRow + End If + + swapCandidate = wsRoster.Cells(r, MOR_COL).Value + If swapCandidate <> "" And swapCandidate <> eligibleStaff Then + ' Check if swap is allowed (no conflict in destination and original slot) + If Not IsWorkingOnSameDay(r, eligibleStaff) And Not IsWorkingOnSameDay(emptyRow, swapCandidate) Then + ' Perform swap + wsRoster.Cells(r, MOR_COL).Value = eligibleStaff + Call IncrementDutiesCounter(eligibleStaff) + Debug.Print "Assigned " & eligibleStaff & " to row " & r + + wsRoster.Cells(emptyRow, MOR_COL).Value = swapCandidate + Debug.Print "Assigned " & swapCandidate & " to row " & emptyRow + + Exit Sub ' Exit after successful swap + Else + Debug.Print "Swap not possible at row " & r & " due to conflict (dest: " & r & ", orig: " & emptyRow & ")" + End If + End If +NextRow: + Next r End Sub -' Helper to shuffle array of strings -Sub ShuffleArrayString(arr() As String) - Dim i As Long, j As Long, tmp As String +' Helper to find the last unfilled slot +Function FindLastUnfilledSlot(startRow As Long, endRow As Long) As Long + Dim r As Long + FindLastUnfilledSlot = 0 + For r = startRow To endRow + If wsRoster.Cells(r, DAY_COL).Value <> "Sat" And _ + wsRoster.Cells(r, MOR_COL).Value = "" Then + FindLastUnfilledSlot = r + End If + Next r +End Function + +' 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) @@ -267,7 +286,7 @@ Function GetEligibleRows(totalDays As Long, workDays As Variant) As Collection 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: show what day we are checking Debug.Print "Row " & r & ": " & dayName @@ -289,7 +308,7 @@ Function GetEligibleRows(totalDays As Long, workDays As Variant) As Collection SkipRow: Next r - Debug.Print "Total Eligible: " & eligibleRows.Count + Debug.Print "Total Eligible: " & eligibleRows.count Set GetEligibleRows = eligibleRows End Function @@ -350,3 +369,24 @@ Function IsWorkingOnSameDay(row As Long, staffName As String) As Boolean IsWorkingOnSameDay = False End Function +' Helper to get the first eligible staff (duties < max) +Function GetFirstEligibleStaff() As String + Dim i As Long + For i = 1 To morningtbl.ListRows.count + Dim staffName As String + Dim maxDuties As Long + Dim currDuties As Long + staffName = morningtbl.DataBodyRange(i, morningtbl.ListColumns("Name").Index).Value + maxDuties = morningtbl.DataBodyRange(i, morningtbl.ListColumns("Max Duties").Index).Value + currDuties = morningtbl.DataBodyRange(i, morningtbl.ListColumns("Duties Counter").Index).Value + If UCase(morningtbl.DataBodyRange(i, morningtbl.ListColumns("Availability Type").Index).Value) <> "SPECIFIC DAYS" And _ + currDuties < maxDuties Then + GetFirstEligibleStaff = staffName + Exit Function + End If + Next i + GetFirstEligibleStaff = "" +End Function + + +