From ce34a2bee6273fac9c05fa31c8ce77a44a9dcf02 Mon Sep 17 00:00:00 2001 From: Casielim Date: Fri, 18 Jul 2025 14:18:42 +0800 Subject: [PATCH 1/2] Add AssignLoanMailBoxDuties.bas --- .../AssignLoanMailBoxDuties.bas | 383 ++++++++++++++++++ 1 file changed, 383 insertions(+) create mode 100644 VBA/VBA-Code_By_Modules/AssignLoanMailBoxDuties.bas diff --git a/VBA/VBA-Code_By_Modules/AssignLoanMailBoxDuties.bas b/VBA/VBA-Code_By_Modules/AssignLoanMailBoxDuties.bas new file mode 100644 index 0000000..86cf47e --- /dev/null +++ b/VBA/VBA-Code_By_Modules/AssignLoanMailBoxDuties.bas @@ -0,0 +1,383 @@ +Attribute VB_Name = "AssignLoanMailBoxDuties" +' Declare worksheet and table +Private wsRoster As Worksheet +Private wsPersonnel As Worksheet +Private wsSettings As Worksheet +Private lmbtbl As ListObject +Private spectbl As ListObject + +Sub AssignLoanMailBoxDuties() + Set wsRoster = Sheets("MasterCopy (2)") + Set wsSettings = Sheets("Settings") + Set wsPersonnel = Sheets("Loan Mail Box PersonnelList") + Set lmbtbl = wsPersonnel.ListObjects("LoanMailBoxMainList") + Set spectbl = wsPersonnel.ListObjects("LoanMailBoxSpecificDaysWorkingStaff") + + 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 + + totalDays = wsRoster.Range(wsRoster.Cells(START_ROW, DATE_COL), wsRoster.Cells(LAST_ROW_ROSTER, DATE_COL)).Rows.Count + + ' 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 lmbtbl.ListRows.Count + If lmbtbl.DataBodyRange(r, lmbtbl.ListColumns("Name").Index).Value = staffName Then + maxDuties = lmbtbl.DataBodyRange(r, lmbtbl.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 + 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 + wsRoster.Cells(tmpRows(j), LMB_COL).Value = staffName + Call IncrementDutiesCounter(staffName) + assignedCount = assignedCount + 1 + End If + Next j + Next i + + ' Step 2: Assign All Days Staff + For r = START_ROW To LAST_ROW_ROSTER + If wsRoster.Cells(r, DAY_COL).Value = "Sat" Then GoTo SkipDay + If wsRoster.Cells(r, LMB_COL).Value = "CLOSED" Then GoTo SkipDay + For i = 1 To lmbtbl.ListRows.Count + staffName = lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Name").Index).Value + If UCase(lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Availability Type").Index).Value) = "SPECIFIC DAYS" Then + GoTo SkipStaff + End If + + maxDuties = lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Max Duties").Index).Value + Dim currDuties As Long + currDuties = lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Duties Counter").Index).Value + ' 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 wsRoster.Cells(r, LMB_COL).Value = "" Then + wsRoster.Cells(r, LMB_COL).Value = staffName + Call IncrementDutiesCounter(staffName) + Exit For + End If + +SkipStaff: + Next i + +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 lmbtbl.ListRows.Count + staffName = lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Name").Index).Value + maxDuties = lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Max Duties").Index).Value + currDuties = lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Duties Counter").Index).Value + If UCase(lmbtbl.DataBodyRange(i, lmbtbl.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, LMB_COL).Value <> "" And wsRoster.Cells(r, LMB_COL).Value <> "CLOSED" Then + staffName = wsRoster.Cells(r, LMB_COL).Value + For i = 1 To lmbtbl.ListRows.Count + If lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Name").Index).Value = staffName And _ + UCase(lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Availability Type").Index).Value) <> "SPECIFIC DAYS" Then + wsRoster.Cells(r, LMB_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 lmbtbl.ListRows.Count + staffName = lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Name").Index).Value + If UCase(lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Availability Type").Index).Value) <> "SPECIFIC DAYS" Then + maxDuties = lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Max Duties").Index).Value + currDuties = lmbtbl.DataBodyRange(i, lmbtbl.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, LMB_COL).Value <> "" Or wsRoster.Cells(r, LMB_COL).Value = "CLOSED" Then GoTo SkipReassignDay + + For i = 1 To UBound(tmpStaff) + staffName = tmpStaff(i) + For j = 1 To lmbtbl.ListRows.Count + If lmbtbl.DataBodyRange(j, lmbtbl.ListColumns("Name").Index).Value = staffName And _ + UCase(lmbtbl.DataBodyRange(j, lmbtbl.ListColumns("Availability Type").Index).Value) <> "SPECIFIC DAYS" Then + maxDuties = lmbtbl.DataBodyRange(j, lmbtbl.ListColumns("Max Duties").Index).Value + currDuties = lmbtbl.DataBodyRange(j, lmbtbl.ListColumns("Duties Counter").Index).Value + If currDuties < maxDuties And Not IsWorkingOnSameDay(r, staffName) Then + wsRoster.Cells(r, LMB_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, LMB_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 + +' 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 + +' 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 + 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(wsRoster.Cells(r, LMB_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 = lmbtbl.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 - lmbtbl.HeaderRowRange.row + + ' Increment Duties Counter + With lmbtbl.ListRows(rowIdx).Range.Cells(lmbtbl.ListColumns("Duties Counter").Index) + .Value = .Value + 1 + End With + Else + MsgBox "Staff '" & staffName & "' not found in table.", vbExclamation + End If +End Sub + +Sub DecrementDutiesCounter(staffName As String) + Dim rowIdx As Variant + Dim foundCell As Range + + ' Search for the staff name + Set foundCell = lmbtbl.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 - lmbtbl.HeaderRowRange.row + + ' Decrement Duties Counter + With lmbtbl.ListRows(rowIdx).Range.Cells(lmbtbl.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 + Dim weekStart As Long + Dim weekEnd As Long + Dim dutyCount As Long + + 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 & ", End = " & weekEnd + dutyCount = 0 + For i = weekStart To weekEnd + If i >= startRow And i < endRow And (ws.Cells(i, LMB_COL).Value = staffName Or ws.Cells(i, SAT_AOH_COL1).Value = staffName Or ws.Cells(i, SAT_AOH_COL2).Value = staffName) Then + dutyCount = dutyCount + 1 + If dutyCount >= 1 Then + CheckWeeklyLimit = False + Exit Function + End If + End If + Next i + CheckWeeklyLimit = True +End Function + +Function IsWorkingOnSameDay(row As Long, staffName As String) As Boolean + If wsRoster.Cells(row, MOR_COL).Value = staffName Then + IsWorkingOnSameDay = True + Exit Function + End If + + If wsRoster.Cells(row, AFT_COL).Value = staffName Then + IsWorkingOnSameDay = True + Exit Function + End If + + If wsRoster.Cells(row, AOH_COL).Value = staffName Then + IsWorkingOnSameDay = True + Exit Function + End If + + IsWorkingOnSameDay = False +End Function + From c89f8abd07edf261817e63719f5feb26aab3e24c Mon Sep 17 00:00:00 2001 From: Casielim Date: Thu, 31 Jul 2025 22:32:36 +0800 Subject: [PATCH 2/2] Set reassignment --- .../AssignLoanMailBoxDuties.bas | 361 +++++++++--------- 1 file changed, 187 insertions(+), 174 deletions(-) diff --git a/VBA/VBA-Code_By_Modules/AssignLoanMailBoxDuties.bas b/VBA/VBA-Code_By_Modules/AssignLoanMailBoxDuties.bas index 86cf47e..95cbdbc 100644 --- a/VBA/VBA-Code_By_Modules/AssignLoanMailBoxDuties.bas +++ b/VBA/VBA-Code_By_Modules/AssignLoanMailBoxDuties.bas @@ -1,13 +1,11 @@ Attribute VB_Name = "AssignLoanMailBoxDuties" ' Declare worksheet and table -Private wsRoster As Worksheet Private wsPersonnel As Worksheet -Private wsSettings As Worksheet Private lmbtbl As ListObject Private spectbl As ListObject Sub AssignLoanMailBoxDuties() - Set wsRoster = Sheets("MasterCopy (2)") + Set wsRoster = Sheets("Roster") Set wsSettings = Sheets("Settings") Set wsPersonnel = Sheets("Loan Mail Box PersonnelList") Set lmbtbl = wsPersonnel.ListObjects("LoanMailBoxMainList") @@ -21,11 +19,16 @@ Sub AssignLoanMailBoxDuties() 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 + totalDays = wsRoster.Range(wsRoster.Cells(START_ROW, DATE_COL), wsRoster.Cells(last_row_roster, DATE_COL)).Rows.count + Debug.Print "Loan Mailbox 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, ",") @@ -35,8 +38,8 @@ Sub AssignLoanMailBoxDuties() workDays(j) = Trim(workDays(j)) Next j - ' Get max duties for this staff from MorningMainList - For r = 1 To lmbtbl.ListRows.Count + ' Get max duties for this staff from LoanMailBoxMainList + For r = 1 To lmbtbl.ListRows.count If lmbtbl.DataBodyRange(r, lmbtbl.ListColumns("Name").Index).Value = staffName Then maxDuties = lmbtbl.DataBodyRange(r, lmbtbl.ListColumns("Max Duties").Index).Value Exit For @@ -44,24 +47,19 @@ Sub AssignLoanMailBoxDuties() 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), LMB_COL).Value = staffName Call IncrementDutiesCounter(staffName) @@ -71,10 +69,10 @@ Sub AssignLoanMailBoxDuties() 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, LMB_COL).Value = "CLOSED" Then GoTo SkipDay - For i = 1 To lmbtbl.ListRows.Count + For i = 1 To lmbtbl.ListRows.count staffName = lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Name").Index).Value If UCase(lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Availability Type").Index).Value) = "SPECIFIC DAYS" Then GoTo SkipStaff @@ -100,152 +98,173 @@ 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 lmbtbl.ListRows.Count - staffName = lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Name").Index).Value - maxDuties = lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Max Duties").Index).Value - currDuties = lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Duties Counter").Index).Value - If UCase(lmbtbl.DataBodyRange(i, lmbtbl.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, LMB_COL).Value <> "" And wsRoster.Cells(r, LMB_COL).Value <> "CLOSED" Then - staffName = wsRoster.Cells(r, LMB_COL).Value - For i = 1 To lmbtbl.ListRows.Count - If lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Name").Index).Value = staffName And _ - UCase(lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Availability Type").Index).Value) <> "SPECIFIC DAYS" Then - wsRoster.Cells(r, LMB_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 lmbtbl.ListRows.Count + If unfilledSlots > 0 And eligibleStaffCount > 0 Then + ' Enter reassignment phase + Call ReassignLoanMailBoxDuties + 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 lmbtbl.ListRows.count staffName = lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Name").Index).Value - If UCase(lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Availability Type").Index).Value) <> "SPECIFIC DAYS" Then - maxDuties = lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Max Duties").Index).Value - currDuties = lmbtbl.DataBodyRange(i, lmbtbl.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 = lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Max Duties").Index).Value + currDuties = lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Duties Counter").Index).Value + If UCase(lmbtbl.DataBodyRange(i, lmbtbl.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, LMB_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, LMB_COL).Value <> "" Or wsRoster.Cells(r, LMB_COL).Value = "CLOSED" Then GoTo SkipReassignDay - - For i = 1 To UBound(tmpStaff) - staffName = tmpStaff(i) - For j = 1 To lmbtbl.ListRows.Count - If lmbtbl.DataBodyRange(j, lmbtbl.ListColumns("Name").Index).Value = staffName And _ - UCase(lmbtbl.DataBodyRange(j, lmbtbl.ListColumns("Availability Type").Index).Value) <> "SPECIFIC DAYS" Then - maxDuties = lmbtbl.DataBodyRange(j, lmbtbl.ListColumns("Max Duties").Index).Value - currDuties = lmbtbl.DataBodyRange(j, lmbtbl.ListColumns("Duties Counter").Index).Value - If currDuties < maxDuties And Not IsWorkingOnSameDay(r, staffName) Then - wsRoster.Cells(r, LMB_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, LMB_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, LMB_COL).Value = staffName + wsRoster.Cells(r, LMB_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 MOR/AFT/AOH 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 Loan Mailbox 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, LMB_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 lmbtbl.ListRows.count + Dim staffName As String + Dim maxDuties As Long + Dim currDuties As Long + staffName = lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Name").Index).Value + maxDuties = lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Max Duties").Index).Value + currDuties = lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Duties Counter").Index).Value + If UCase(lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Availability Type").Index).Value) <> "SPECIFIC DAYS" And _ + currDuties < maxDuties Then + count = count + 1 + End If Next i + CountEligibleStaff = count +End Function + +Sub ReassignLoanMailBoxDuties() + 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 LMB reassignment." + Exit Sub + End If + Debug.Print "Eligible staff for LMB 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, LMB_COL).Value = "CLOSED" Or _ + wsRoster.Cells(r, LMB_COL).Value = "" Then + GoTo NextRow + End If + + swapCandidate = wsRoster.Cells(r, LMB_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, LMB_COL).Value = eligibleStaff + Call IncrementDutiesCounter(eligibleStaff) + Debug.Print "Assigned " & eligibleStaff & " to row " & r + + wsRoster.Cells(emptyRow, LMB_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, LMB_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) @@ -266,7 +285,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 @@ -288,7 +307,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 @@ -335,33 +354,6 @@ Sub DecrementDutiesCounter(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 - Dim weekStart As Long - Dim weekEnd As Long - Dim dutyCount As Long - - 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 & ", End = " & weekEnd - dutyCount = 0 - For i = weekStart To weekEnd - If i >= startRow And i < endRow And (ws.Cells(i, LMB_COL).Value = staffName Or ws.Cells(i, SAT_AOH_COL1).Value = staffName Or ws.Cells(i, SAT_AOH_COL2).Value = staffName) Then - dutyCount = dutyCount + 1 - If dutyCount >= 1 Then - CheckWeeklyLimit = False - Exit Function - End If - End If - Next i - CheckWeeklyLimit = True -End Function - Function IsWorkingOnSameDay(row As Long, staffName As String) As Boolean If wsRoster.Cells(row, MOR_COL).Value = staffName Then IsWorkingOnSameDay = True @@ -381,3 +373,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 lmbtbl.ListRows.count + Dim staffName As String + Dim maxDuties As Long + Dim currDuties As Long + staffName = lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Name").Index).Value + maxDuties = lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Max Duties").Index).Value + currDuties = lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Duties Counter").Index).Value + If UCase(lmbtbl.DataBodyRange(i, lmbtbl.ListColumns("Availability Type").Index).Value) <> "SPECIFIC DAYS" And _ + currDuties < maxDuties Then + GetFirstEligibleStaff = staffName + Exit Function + End If + Next i + GetFirstEligibleStaff = "" +End Function + + +