From b4d4e0f05b2228914f6821440f9c664f34df08b4 Mon Sep 17 00:00:00 2001 From: Casielim Date: Sat, 5 Jul 2025 12:21:05 +0800 Subject: [PATCH] Make a copy of all the modules --- .../AssignEmployeeCopy.bas | 274 ++++++++++++++++-- .../CalculateMaxDuties.bas | 64 ++++ VBA/VBA-Code_By_Modules/ClearTableContent.bas | 9 + .../InsertStaffCounter.bas | 30 +- VBA/VBA-Code_By_Modules/ResetAOHCounter.bas | 14 +- .../ResetDutiesAOHCounter.bas | 14 - VBA/VBA-Code_By_Modules/Swap.bas | 223 +++++++++++--- 7 files changed, 520 insertions(+), 108 deletions(-) create mode 100644 VBA/VBA-Code_By_Modules/CalculateMaxDuties.bas create mode 100644 VBA/VBA-Code_By_Modules/ClearTableContent.bas diff --git a/VBA/VBA-Code_By_Modules/AssignEmployeeCopy.bas b/VBA/VBA-Code_By_Modules/AssignEmployeeCopy.bas index eb9a13f..1816af3 100644 --- a/VBA/VBA-Code_By_Modules/AssignEmployeeCopy.bas +++ b/VBA/VBA-Code_By_Modules/AssignEmployeeCopy.bas @@ -1,7 +1,34 @@ Attribute VB_Name = "AssignEmployeeCopy" +'declare worksheet and table + Private wsRosterCopy As Worksheet + Private wsPersonnel As Worksheet + Private wsSettings As Worksheet + Private morningtbl As ListObject + +'declare roster column number + Private dateCol As Long + Private dayCol As Long + Private LMBCol As Long + Private morCol As Long + Private aftCol As Long + Private AOHCol As Long + Private satAOHCol1 As Long + Private satAOHCol2 As Long + Sub AssignFirstEmployeeToFirstSlotCopy() - Dim wsRosterCopy As Worksheet - Dim wsPersonnel As Worksheet + Set wsRosterCopy = Sheets("MasterCopy") + Set wsPersonnel = Sheets("PersonnelList (AOH & Desk)") + Set wsSettings = Sheets("Settings") + + dateCol = 2 + dayCol = 3 + LMBCol = 4 + morCol = 6 + aftCol = 8 + AOHCol = 10 + satAOHCol1 = 12 + satAOHCol2 = 14 + Dim slotCols As Variant Dim slotCol As Variant Dim slotCell As Range @@ -22,10 +49,7 @@ Sub AssignFirstEmployeeToFirstSlotCopy() Dim isVacation As Boolean Dim lastRowRoster As Integer - Set wsRosterCopy = Sheets("MasterCopy") - Set wsPersonnel = Sheets("PersonnelList (AOH & Desk)") - Set wsSettings = Sheets("Settings") - + ' Find last row number of the employee list lastRow = wsPersonnel.Cells(wsPersonnel.Rows.Count, "B").End(xlUp).Row found = False @@ -42,33 +66,33 @@ Sub AssignFirstEmployeeToFirstSlotCopy() 'Loop through each date row For dateRow = 6 To lastRowRoster - currDate = wsRosterCopy.Cells(dateRow, 2).Value + currDate = wsRosterCopy.Cells(dateRow, dateCol).Value If Weekday(currDate, vbMonday) = 7 Or _ Application.WorksheetFunction.CountIf(wsSettings.Range("Settings_Holidays"), currDate) > 0 Then ' Skip this date by marking all slots as "CLOSED" - wsRosterCopy.Cells(dateRow, 4).Value = "CLOSED" ' D column - wsRosterCopy.Cells(dateRow, 4).Interior.Color = vbRed + wsRosterCopy.Cells(dateRow, LMBCol).Value = "CLOSED" ' D column + wsRosterCopy.Cells(dateRow, LMBCol).Interior.Color = vbRed - wsRosterCopy.Cells(dateRow, 6).Value = "CLOSED" ' F column - wsRosterCopy.Cells(dateRow, 6).Interior.Color = vbRed + wsRosterCopy.Cells(dateRow, morCol).Value = "CLOSED" ' F column + wsRosterCopy.Cells(dateRow, morCol).Interior.Color = vbRed - wsRosterCopy.Cells(dateRow, 8).Value = "CLOSED" ' H column - wsRosterCopy.Cells(dateRow, 8).Interior.Color = vbRed + wsRosterCopy.Cells(dateRow, aftCol).Value = "CLOSED" ' H column + wsRosterCopy.Cells(dateRow, aftCol).Interior.Color = vbRed - wsRosterCopy.Cells(dateRow, 10).Value = "CLOSED" ' J column - wsRosterCopy.Cells(dateRow, 10).Interior.Color = vbRed + wsRosterCopy.Cells(dateRow, AOHCol).Value = "CLOSED" ' J column + wsRosterCopy.Cells(dateRow, AOHCol).Interior.Color = vbRed - wsRosterCopy.Cells(dateRow, 12).Value = "CLOSED" ' L column - wsRosterCopy.Cells(dateRow, 12).Interior.Color = vbRed + wsRosterCopy.Cells(dateRow, satAOHCol1).Value = "CLOSED" ' L column + wsRosterCopy.Cells(dateRow, satAOHCol1).Interior.Color = vbRed - wsRosterCopy.Cells(dateRow, 14).Value = "CLOSED" ' N column - wsRosterCopy.Cells(dateRow, 14).Interior.Color = vbRed + wsRosterCopy.Cells(dateRow, satAOHCol2).Value = "CLOSED" ' N column + wsRosterCopy.Cells(dateRow, satAOHCol2).Interior.Color = vbRed GoTo NextDate ' Skip to the next date End If - For Each slotCol In Array(4, 6, 8, 10, 12, 14) ' D, F, H, J, L, N columns + For Each slotCol In Array(LMBCol, morCol, aftCol, AOHCol, satAOHCol1, satAOHCol2) ' D, F, H, J, L, N columns Set slotCell = wsRosterCopy.Cells(dateRow, slotCol) slotCell.Interior.ColorIndex = xlNone ' Reset to no fill (default) slotCell.Font.Strikethrough = False @@ -79,7 +103,7 @@ Sub AssignFirstEmployeeToFirstSlotCopy() isVacation = (wsRosterCopy.Cells(dateRow, 1).Value = "Vacation") If isSaturday Then - slotCols = Array(12, 14) ' L, N for Saturday + slotCols = Array(satAOHCol1, satAOHCol2) ' L, N for Saturday ElseIf isVacation Then slotCols = Array(6, 8) ' F, H only for vacation weekdays (no J AOH) Else @@ -93,7 +117,7 @@ Sub AssignFirstEmployeeToFirstSlotCopy() For Each slotCol In slotCols Set slotCell = wsRosterCopy.Cells(dateRow, slotCol) isAohSlot = (slotCol = 10 Or isSaturday) And Not isVacation ' J, L, or N as AOH - found = False + found = Falsez 'Loop through each staff For currRow = 12 To lastRow @@ -156,8 +180,206 @@ NextDate: End Sub +Function countMorningOrAfternoonSlotsUDF() As Long + Application.Volatile + Dim startDate As Date + Dim endDate As Date + Dim currentDate As Date + Dim r As Long + Dim lastRow As Long + Dim holidayCell As Range + Dim isHoliday As Boolean + Dim ws As Worksheet + + ' Initialize counter + countMorningOrAfternoonSlotsUDF = 0 + + ' Set worksheet reference + Set ws = ThisWorkbook.Sheets("MasterCopy") + + ' Get the fixed start and end dates from H3 and K3 + startDate = ws.Range("H3").Value + endDate = ws.Range("K3").Value + If Not IsDate(startDate) Or Not IsDate(endDate) Then Exit Function ' Exit if dates are invalid + + ' Ensure startDate is before or equal to endDate + If startDate > endDate Then + Dim tempDate As Date + tempDate = startDate + startDate = endDate + endDate = tempDate + End If + + ' Determine the last row with a valid date in column B + lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row + Do While lastRow >= 6 + If IsDate(Trim(ws.Cells(lastRow, 2).Value)) Then + Exit Do + Else + lastRow = lastRow - 1 + End If + Loop + If lastRow < 6 Then Exit Function ' No valid dates found + + ' Loop through each row in column B + For r = 6 To lastRow + currentDate = ws.Cells(r, 2).Value ' Date from column B + If IsDate(Trim(currentDate)) Then + ' Check if the date is within the custom period + If currentDate >= startDate And currentDate <= endDate Then + ' Check if it's not Sunday (1) or Saturday (7) + If Weekday(currentDate) <> 1 And Weekday(currentDate) <> 7 Then + ' Check if it's not a public holiday using the named range + isHoliday = False + For Each holidayCell In Range("Settings_Holidays") + If IsDate(holidayCell.Value) Then + If DateValue(currentDate) = DateValue(holidayCell.Value) Then + isHoliday = True + Exit For + End If + End If + Next holidayCell + ' If not a holiday, increment counter + If Not isHoliday Then + countMorningOrAfternoonSlotsUDF = countMorningOrAfternoonSlotsUDF + 1 + End If + End If + End If + End If + Next r +End Function +Function countAOHslotsUDF() As Long + Dim startDate As Date + Dim endDate As Date + Dim currentDate As Date + Dim r As Long + Dim lastRow As Long + Dim holidayCell As Range + Dim isHoliday As Boolean + Dim ws As Worksheet + + ' Initialize counter + countAOHslotsUDF = 0 + + ' Set worksheet reference + Set ws = ThisWorkbook.Sheets("MasterCopy") + + ' Get the fixed start and end dates from H3 and K3 + startDate = ws.Range("H3").Value + endDate = ws.Range("K3").Value + If Not IsDate(startDate) Or Not IsDate(endDate) Then Exit Function ' Exit if dates are invalid + + ' Ensure startDate is before or equal to endDate + If startDate > endDate Then + Dim tempDate As Date + tempDate = startDate + startDate = endDate + endDate = tempDate + End If + + ' Determine the last row with a valid date in column B + lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row + Do While lastRow >= 6 + If IsDate(Trim(ws.Cells(lastRow, 2).Value)) Then + Exit Do + Else + lastRow = lastRow - 1 + End If + Loop + If lastRow < 6 Then Exit Function ' No valid dates found + + ' Loop through each row in column B + For r = 6 To lastRow + currentDate = ws.Cells(r, 2).Value ' Date from column B + If IsDate(Trim(currentDate)) Then + ' Check if the date is within the custom period + If currentDate >= startDate And currentDate <= endDate Then + ' Check if it's not Sunday (1) or Saturday (7) + If Weekday(currentDate) <> 1 And Weekday(currentDate) <> 7 Then + ' Check if it's not a public holiday using the named range + isHoliday = False + For Each holidayCell In Range("Settings_Holidays") + If IsDate(holidayCell.Value) Then + If DateValue(currentDate) = DateValue(holidayCell.Value) Then + isHoliday = True + Exit For + End If + End If + Next holidayCell + ' Check if the corresponding marker in column A is "sem time" + If Not isHoliday And LCase(Trim(ws.Cells(r, 1).Value)) = "sem time" Then + countAOHslotsUDF = countAOHslotsUDF + 1 + End If + End If + End If + End If + Next r +End Function - - - - +Function countSatAOH() As Long + Dim startDate As Date + Dim endDate As Date + Dim currentDate As Date + Dim r As Long + Dim lastRow As Long + Dim holidayCell As Range + Dim isHoliday As Boolean + Dim ws As Worksheet + + ' Initialize counter + countSatAOH = 0 + + ' Set worksheet reference + Set ws = ThisWorkbook.Sheets("MasterCopy") + + ' Get the fixed start and end dates from H3 and K3 + startDate = ws.Range("H3").Value + endDate = ws.Range("K3").Value + If Not IsDate(startDate) Or Not IsDate(endDate) Then Exit Function ' Exit if dates are invalid + + ' Ensure startDate is before or equal to endDate + If startDate > endDate Then + Dim tempDate As Date + tempDate = startDate + startDate = endDate + endDate = tempDate + End If + + ' Determine the last row with a valid date in column B + lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row + Do While lastRow >= 6 + If IsDate(Trim(ws.Cells(lastRow, 2).Value)) Then + Exit Do + Else + lastRow = lastRow - 1 + End If + Loop + If lastRow < 6 Then Exit Function ' No valid dates found + + ' Loop through each row in column B + For r = 6 To lastRow + currentDate = ws.Cells(r, 2).Value ' Date from column B + If IsDate(Trim(currentDate)) Then + ' Check if the date is within the custom period + If currentDate >= startDate And currentDate <= endDate Then + ' Check if it's a Saturday (7) + If Weekday(currentDate) = 7 Then + ' Check if it's not a public holiday using the named range + isHoliday = False + For Each holidayCell In Range("Settings_Holidays") + If IsDate(holidayCell.Value) Then + If DateValue(currentDate) = DateValue(holidayCell.Value) Then + isHoliday = True + Exit For + End If + End If + Next holidayCell + ' If not a holiday, increment counter + If Not isHoliday Then + countSatAOH = countSatAOH + 1 + End If + End If + End If + End If + Next r +End Function diff --git a/VBA/VBA-Code_By_Modules/CalculateMaxDuties.bas b/VBA/VBA-Code_By_Modules/CalculateMaxDuties.bas new file mode 100644 index 0000000..30f1d35 --- /dev/null +++ b/VBA/VBA-Code_By_Modules/CalculateMaxDuties.bas @@ -0,0 +1,64 @@ +Attribute VB_Name = "CalculateMaxDuties" +Sub CalculateMaxDuties() + Dim ws As Worksheet + Dim morningtbl As ListObject + Set ws = ThisWorkbook.Sheets("PersonnelList Copy") + Set morningtbl = ws.ListObjects("MorningMainList") + + Dim totalDuties As Long + Dim totalStaff As Long + Dim fullDuties As Long + Dim i As Long + Dim remaining As Long + Dim totalAssigned As Long + Dim dutiesPercentage As Double + Dim eligibleCount As Long + Dim eligible100() As Long 'Store the indices of staff with 100% duty + Dim j As Long + Dim rounded() As Long + + totalStaff = morningtbl.ListRows.Count + totalDuties = ws.Range("H6").Value + fullDuties = WorksheetFunction.RoundDown(totalDuties / totalStaff, 0) + remaining = 0 + eligibleCount = 0 + + ReDim eligible100(1 To totalStaff) + ReDim rounded(1 To totalStaff) + + 'Calculate initial duties and max cap + For i = 1 To totalStaff + dutiesPercentage = morningtbl.ListRows(i).Range.Cells(morningtbl.ListColumns("Duties Percentage (%)").Index).Value + + If dutiesPercentage < 100 Then + rounded(i) = CLng(fullDuties * (dutiesPercentage / 100)) + Else + rounded(i) = fullDuties + 'Mark eligible 100% staff for distribution + eligibleCount = eligibleCount + 1 + eligible100(eligibleCount) = i + End If + + totalAssigned = totalAssigned + rounded(i) + Next i + + 'Distribute remaining slots to 100% staff + remaining = totalDuties - totalAssigned + + If remaining > 0 Then + If eligibleCount > 0 Then + For j = 1 To remaining + i = eligible100(((j - 1) Mod eligibleCount) + 1) 'rotate among 100% staff + rounded(i) = rounded(i) + 1 + Next j + Else + MsgBox "No available staff to assign remaining duties" + End If + End If + + 'Write results back to sheet + For i = 1 To totalStaff + morningtbl.ListRows(i).Range.Cells(morningtbl.ListColumns("Max Duties").Index).Value = rounded(i) + Next i + +End Sub diff --git a/VBA/VBA-Code_By_Modules/ClearTableContent.bas b/VBA/VBA-Code_By_Modules/ClearTableContent.bas new file mode 100644 index 0000000..b464180 --- /dev/null +++ b/VBA/VBA-Code_By_Modules/ClearTableContent.bas @@ -0,0 +1,9 @@ +Attribute VB_Name = "ClearTableContent" +Public Sub ClearTableContent() +' +' ClearTableContent Macro +' + Range("D6:O189").Select + Selection.ClearContents + Selection.Rows.AutoFit +End Sub diff --git a/VBA/VBA-Code_By_Modules/InsertStaffCounter.bas b/VBA/VBA-Code_By_Modules/InsertStaffCounter.bas index e8bc18e..38cf88d 100644 --- a/VBA/VBA-Code_By_Modules/InsertStaffCounter.bas +++ b/VBA/VBA-Code_By_Modules/InsertStaffCounter.bas @@ -1,6 +1,7 @@ Attribute VB_Name = "InsertStaffCounter" -Sub InsertStaffCounter() +Public Sub InsertStaffCounter() Dim ws As Worksheet + Dim newRow As Long Dim lastRow As Long Dim staffName As String, dept As String Dim maxDuties As Variant @@ -11,6 +12,7 @@ Sub InsertStaffCounter() matchRow = 0 Set ws = ThisWorkbook.Sheets("PersonnelList (AOH & Desk)") + lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row ' Read correct cell values staffName = UCase(Trim(ws.Range("C3").Value)) ' Name @@ -24,7 +26,7 @@ Sub InsertStaffCounter() End If ' Check for duplicate names - For checkRow = 10 To 1000 + For checkRow = 10 To lastRow If ws.Cells(checkRow, 2).Value = staffName Then MsgBox "This staff name already exists. ", vbExclamation Exit Sub @@ -44,23 +46,17 @@ Sub InsertStaffCounter() ' Find next empty row based on column B (Name) - lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row + 1 - - ' Insert data into row - ws.Cells(lastRow, 2).Value = staffName ' Name - ws.Cells(lastRow, 3).Value = dept ' Dept - ws.Cells(lastRow, 4).Value = maxDuties ' Max Duties + newRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row + 1 ' Set Duties Counter If Trim(ws.Range("C6").Value) = "" Then - ws.Cells(lastRow, 5).Value = 0 + ws.Cells(newRow, 5).Value = 0 Else - ws.Cells(lastRow, 5).Value = ws.Range("C6").Value + ws.Cells(newRow, 5).Value = ws.Range("C6").Value End If - ' Search column B (Name) from row 10 to 1000 - For i = 10 To 1000 - If ws.Cells(i, 2).Value = staffName Then + For i = 10 To lastRow + If UCase(Trim(ws.Cells(i, 2).Value)) = UCase(Trim(staffName)) Then matchRow = i Exit For End If @@ -70,10 +66,10 @@ Sub InsertStaffCounter() If Trim(ws.Range("C7").Value) = "" Then ws.Cells(matchRow, 6).Value = 0 Else - If Trim(ws.Range("C7").Value) > 1 Then - MsgBox "AOH Counter must not be more than 1.", vbExclamation - Exit Sub - End If + If Trim(ws.Range("C7").Value) > 1 Then + MsgBox "AOH Counter must not be more than 1.", vbExclamation + Exit Sub + End If ws.Cells(matchRow, 6).Value = ws.Range("C7").Value End If diff --git a/VBA/VBA-Code_By_Modules/ResetAOHCounter.bas b/VBA/VBA-Code_By_Modules/ResetAOHCounter.bas index eabb1b2..4471064 100644 --- a/VBA/VBA-Code_By_Modules/ResetAOHCounter.bas +++ b/VBA/VBA-Code_By_Modules/ResetAOHCounter.bas @@ -11,21 +11,17 @@ Public Sub ResetAOHCounter() isAllOne = True For i = 12 To lastRow - If Trim(ws.Cells(i, 2).Value) <> "" Then - If ws.Cells(i, 6).Value <> 1 Then - isAllOne = False - - Exit For - End If + If ws.Cells(i, 6).Value <> 1 Then + isAllOne = False + + Exit For End If Next i ' Reset if all have AOH = 1 If isAllOne Then For i = 12 To lastRow - If Trim(ws.Cells(i, 2).Value) <> "" Then - ws.Cells(i, 6).Value = 0 - End If + ws.Cells(i, 6).Value = 0 Next i End If End Sub diff --git a/VBA/VBA-Code_By_Modules/ResetDutiesAOHCounter.bas b/VBA/VBA-Code_By_Modules/ResetDutiesAOHCounter.bas index fb59f70..3ddc931 100644 --- a/VBA/VBA-Code_By_Modules/ResetDutiesAOHCounter.bas +++ b/VBA/VBA-Code_By_Modules/ResetDutiesAOHCounter.bas @@ -3,8 +3,6 @@ Sub ResetDutiesAOHCounter() Attribute ResetDutiesAOHCounter.VB_ProcData.VB_Invoke_Func = " \n14" ' ' Reset_Duties_AOH_Counter Macro -' - ' Sheets("PersonnelList (AOH & Desk)").Select Range("E12").Select @@ -14,18 +12,6 @@ Attribute ResetDutiesAOHCounter.VB_ProcData.VB_Invoke_Func = " \n14" Range("E12:F12").Select Selection.AutoFill Destination:=Range( _ "Desk_PersonnelList[[Weekly Duties Counter]:[AOH Counter]]") - Range("Desk_PersonnelList[[Weekly Duties Counter]:[AOH Counter]]").Select Sheets("MasterCopy").Select End Sub -Sub ClearTableContent() -Attribute ClearTableContent.VB_ProcData.VB_Invoke_Func = " \n14" -' -' ClearTableContent Macro -' -' - Range("D6:O189").Select - Selection.ClearContents - Cells.Select - Selection.Rows.AutoFit -End Sub diff --git a/VBA/VBA-Code_By_Modules/Swap.bas b/VBA/VBA-Code_By_Modules/Swap.bas index b4a6ac9..816deec 100644 --- a/VBA/VBA-Code_By_Modules/Swap.bas +++ b/VBA/VBA-Code_By_Modules/Swap.bas @@ -1,59 +1,198 @@ Attribute VB_Name = "Swap" +Option Explicit + +' Main subroutine to handle staff swapping Sub SwapStaff() - Dim wsRoster As Worksheet, wsPersonnel As Worksheet, wsSwap As Worksheet - Dim slotCols As Variant, slotCol As Variant - Dim dateCell As Range, dateRange As Range - Dim oriName As String, newName As String - Dim r As Long, i As Long - Dim lastRow As Long + Dim wsRoster As Worksheet + Dim wsPersonnel As Worksheet + Dim wsSwap As Worksheet + Dim slotCols As Variant + Dim dateRange As Range + Dim oriName As String + Dim newName As String + Dim dateCell As Range + + InitializeWorksheets wsRoster, wsPersonnel, wsSwap + GetSwapNames wsSwap, oriName, newName + ValidateNames oriName, newName + + Set dateRange = GetDateRange + If dateRange Is Nothing Then Exit Sub + If Not IsValidDateColumn(dateRange) Then Exit Sub + + slotCols = Array(6, 8, 10, 12, 14) + Dim r As Long + For Each dateCell In dateRange + r = dateCell.Row + Dim oriNameFound As Boolean + CheckOriginalNameExists wsRoster, r, slotCols, oriName, oriNameFound + If Not oriNameFound Then + DisplayError "Error: " & oriName & " not found in row " & r & ". Swap not allowed.", vbExclamation + Else + Dim nameExists As Boolean + CheckNewNameExists wsRoster, r, slotCols, newName, nameExists + If nameExists Then + DisplayError "Error: " & newName & " already exists in row " & r & ". Swap not allowed.", vbExclamation + Else + PerformSwap wsRoster, r, slotCols, oriName, newName, wsPersonnel + End If + End If + Next dateCell + + MsgBox "Swap completed.", vbInformation +End Sub +' Initialize worksheet references +Private Sub InitializeWorksheets(wsRoster As Worksheet, wsPersonnel As Worksheet, wsSwap As Worksheet) Set wsRoster = Sheets("MasterCopy") Set wsPersonnel = Sheets("PersonnelList (AOH & Desk)") Set wsSwap = Sheets("Swap") +End Sub - ' Get names +' Get original and new staff names from Swap sheet +Private Sub GetSwapNames(wsSwap As Worksheet, oriName As String, newName As String) oriName = UCase(Trim(wsSwap.Range("C4").Value)) newName = UCase(Trim(wsSwap.Range("C5").Value)) +End Sub - ' Prompt user to select date cells in Column A +' Validate that names are not empty +Private Sub ValidateNames(oriName As String, newName As String) + If Len(oriName) = 0 Then + MsgBox "Error: Original staff name is empty. Please enter a valid personnel.", vbCritical + Exit Sub + End If + If Len(newName) = 0 Then + MsgBox "Error: New staff name is empty. Please enter a valid personnel.", vbCritical + Exit Sub + End If +End Sub + +' Prompt user to select date range and return it +Private Function GetDateRange() As Range On Error Resume Next - Set dateRange = Application.InputBox("Select date cells (Column A)", Type:=8) + Set GetDateRange = Application.InputBox("Select date cells (Column A)", Type:=8) On Error GoTo 0 - If dateRange Is Nothing Then Exit Sub +End Function - ' Columns: F, H, J, L, N - slotCols = Array(6, 8, 10, 12, 14) +' Validate that the selected range is from column A (column 1) +Private Function IsValidDateColumn(dateRange As Range) As Boolean + If Not dateRange.Columns(1).Column = 2 Then + MsgBox "Please only select dates from Date column.", vbExclamation + IsValidDateColumn = False + Else + IsValidDateColumn = True + End If +End Function - ' Loop over selected date rows - For Each dateCell In dateRange - r = dateCell.Row +' Check if the original name exists in the row +Private Sub CheckOriginalNameExists(wsRoster As Worksheet, r As Long, slotCols As Variant, oriName As String, ByRef oriNameFound As Boolean) + Dim col As Variant + Dim cellValue As String + Dim lines() As String + oriNameFound = False + For Each col In slotCols + cellValue = wsRoster.Cells(r, col).Value + If InStr(cellValue, vbNewLine) > 0 Then + If UCase(Trim(Split(cellValue, vbNewLine)(0))) = oriName Then + oriNameFound = True + End If + Else + If UCase(Trim(cellValue)) = oriName Then + oriNameFound = True + End If + End If + If oriNameFound Then Exit For + Next col +End Sub - For Each slotCol In slotCols - With wsRoster.Cells(r, slotCol) - If UCase(Trim(.Value)) = oriName Then - ' Add new name on a new line and apply strikethrough to original name - .Value = .Value & vbNewLine & newName - .VerticalAlignment = xlTop ' Align text to the top - .WrapText = True - .Characters(1, Len(oriName)).Font.Strikethrough = True - .Characters(Len(.Value) - Len(newName) + 1).Font.Strikethrough = False - .Rows.AutoFit - - ' Update personnel counter for the new staff - lastRow = wsPersonnel.Cells(wsPersonnel.Rows.Count, "B").End(xlUp).Row - For i = 12 To lastRow - If UCase(Trim(wsPersonnel.Cells(i, 2).Value)) = newName Then - wsPersonnel.Cells(i, 5).Value = wsPersonnel.Cells(i, 5).Value + 1 ' Weekly Duties Counter - If slotCol = 10 Or slotCol = 12 Or slotCol = 14 Then ' AOH slots - wsPersonnel.Cells(i, 6).Value = wsPersonnel.Cells(i, 6).Value + 1 - End If - Exit For - End If - Next i - End If - End With - Next slotCol - Next dateCell +' Check if the new name exists in the same row +Private Sub CheckNewNameExists(wsRoster As Worksheet, r As Long, slotCols As Variant, newName As String, ByRef nameExists As Boolean) + Dim col As Variant + Dim cellValue As String + Dim lines() As String + nameExists = False + For Each col In slotCols + cellValue = wsRoster.Cells(r, col).Value + If InStr(cellValue, vbNewLine) > 0 Then + If UCase(Trim(Split(cellValue, vbNewLine)(0))) = newName Then + nameExists = True + End If + Else + If UCase(Trim(cellValue)) = newName Then + nameExists = True + End If + End If + If nameExists Then Exit For + Next col +End Sub + +' Display an error message +Private Sub DisplayError(message As String, messageType As VbMsgBoxStyle) + MsgBox message, messageType +End Sub - MsgBox "Swap complete.", vbInformation +' Perform the swap operation for a given row +Private Sub PerformSwap(wsRoster As Worksheet, r As Long, slotCols As Variant, oriName As String, newName As String, wsPersonnel As Worksheet) + Dim slotCol As Variant + Dim currentName As String + Dim lines() As String + Dim i As Long + Dim lastRow As Long + Dim cumulativeLength As Long + Dim startPos As Integer + + For Each slotCol In slotCols + With wsRoster.Cells(r, slotCol) + ' Determine the current name based on whether there is a line break + If InStr(.Value, vbNewLine) > 0 Then + currentName = Trim(Split(.Value, vbNewLine)(0)) ' First unstriked line for subsequent swaps + Else + currentName = Trim(.Value) ' Entire value for initial swap + End If + + If UCase(currentName) = oriName Then ' Check the current name + ' Add new name first (unstriked) and preserve existing content + .Value = newName & vbNewLine & .Value + .VerticalAlignment = xlTop ' Align text to the top + .WrapText = True + + ' Split into lines to apply strikethrough to all previous names + lines = Split(.Value, vbNewLine) + cumulativeLength = Len(newName) + 2 ' Start with newName and its vbNewLine + + ' Apply strikethrough to all lines except the first one + For i = 1 To UBound(lines) + startPos = cumulativeLength + .Characters(startPos, Len(lines(i)) + 1).Font.Strikethrough = True + cumulativeLength = cumulativeLength + Len(lines(i)) + 2 ' Update for next line + Next i + + ' Explicitly increase row height by 15 points per swap + .RowHeight = .RowHeight + 15 + + ' Update personnel counter for the new staff + lastRow = wsPersonnel.Cells(wsPersonnel.Rows.Count, "B").End(xlUp).Row + ' Deduct duties from the old staff + For i = 12 To lastRow + If UCase(Trim(wsPersonnel.Cells(i, 2).Value)) = oriName Then + wsPersonnel.Cells(i, 5).Value = wsPersonnel.Cells(i, 5).Value - 1 ' Decrement Weekly Duties Counter + If slotCol = 10 Or slotCol = 12 Or slotCol = 14 Then ' AOH slots + wsPersonnel.Cells(i, 6).Value = wsPersonnel.Cells(i, 6).Value - 1 ' Decrement AOH Counter + End If + Exit For + End If + Next i + ' Update duties for the new staff + For i = 12 To lastRow + If UCase(Trim(wsPersonnel.Cells(i, 2).Value)) = newName Then + wsPersonnel.Cells(i, 5).Value = wsPersonnel.Cells(i, 5).Value + 1 ' Increment Weekly Duties Counter + If slotCol = 10 Or slotCol = 12 Or slotCol = 14 Then ' AOH slots + wsPersonnel.Cells(i, 6).Value = wsPersonnel.Cells(i, 6).Value + 1 ' Increment AOH Counter + End If + Exit For + End If + Next i + End If + End With + Next slotCol End Sub