From bfc40fd3a875eb34242964567994e2beeb75c300 Mon Sep 17 00:00:00 2001 From: Si Yu Lew <156303901+bananapielearnsjava@users.noreply.github.com> Date: Wed, 18 Jun 2025 18:05:56 +0800 Subject: [PATCH 1/6] testing --- lab8.circ | 247 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 247 insertions(+) create mode 100644 lab8.circ diff --git a/lab8.circ b/lab8.circ new file mode 100644 index 0000000..337d14e --- /dev/null +++ b/lab8.circ @@ -0,0 +1,247 @@ + + + This file is intended to be loaded by Logisim (http://www.cburch.com/logisim/). + + + + + + + + + + + + + + + + + + addr/data: 8 8 +0 + + + + + + + + + + + + +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + From cba18327ea2456deeaaa595a105eaf08fb44c4cd Mon Sep 17 00:00:00 2001 From: Si Yu Lew <156303901+bananapielearnsjava@users.noreply.github.com> Date: Tue, 15 Jul 2025 01:27:13 +0800 Subject: [PATCH 2/6] Data Entry for Morning Staff --- VBA/VBA-Code_By_Modules/InsertStaffNew.bas | 213 +++++++++++++++++++++ 1 file changed, 213 insertions(+) create mode 100644 VBA/VBA-Code_By_Modules/InsertStaffNew.bas diff --git a/VBA/VBA-Code_By_Modules/InsertStaffNew.bas b/VBA/VBA-Code_By_Modules/InsertStaffNew.bas new file mode 100644 index 0000000..602e992 --- /dev/null +++ b/VBA/VBA-Code_By_Modules/InsertStaffNew.bas @@ -0,0 +1,213 @@ +Attribute VB_Name = "Module1" +Sub InsertStaff() + On Error GoTo ErrHandler + + Dim ws As Worksheet + Dim morningtbl As ListObject + Dim newRow As ListRow + Dim staffName As String, dept As String + Dim availType As String, workDays As String, percentage As String + Dim checkRow As Long + Dim specificDaysTbl As ListObject + + ' Set worksheet and tables + Set ws = ThisWorkbook.Sheets("Morning PersonnelList") + If ws Is Nothing Then + MsgBox "Worksheet 'Morning PersonnelList' not found.", vbExclamation + Exit Sub + End If + On Error Resume Next + Set morningtbl = ws.ListObjects("MorningMainList") + Set specificDaysTbl = ws.ListObjects("MorningSpecificDaysWorkingStaff") + On Error GoTo ErrHandler + If morningtbl Is Nothing Then + MsgBox "Table 'MorningMainList' not found on 'Morning PersonnelList'.", vbExclamation + Exit Sub + End If + If specificDaysTbl Is Nothing And availType = "SPECIFIC DAYS" Then + MsgBox "Table 'MorningSpecificDaysWorkingStaff' not found on 'Morning PersonnelList'.", vbExclamation + Exit Sub + End If + + ' Read correct cell values + staffName = UCase(Trim(ws.Range("D5").Value)) ' Name + dept = Trim(ws.Range("D6").Value) ' Department + availType = UCase(Trim(ws.Range("D7").Value)) ' Availability Type (converted to uppercase for consistency) + workDays = Trim(ws.Range("D8").Value) ' Working Days + percentage = Trim(ws.Range("D9").Value) ' Duties Percentage + + ' Auto-fill logic based on Availability Type + If availType = "ALL DAYS" Then + percentage = "100" ' Auto-fill Duties Percentage to 100% + workDays = "" ' Ignore Working Days for All Days + ElseIf availType = "SPECIFIC DAYS" Then + If workDays = "" Then + MsgBox "Please enter Working Days for Specific Days availability.", vbExclamation + Exit Sub + End If + If percentage = "" Or Not IsNumeric(percentage) Or Val(percentage) <= 0 Or Val(percentage) > 100 Then + MsgBox "Please enter a valid Duties Percentage (1-100) for Specific Days.", vbExclamation + Exit Sub + End If + Else + MsgBox "Availability Type must be 'All Days' or 'Specific Days'.", vbExclamation + Exit Sub + End If + + ' Validation + If Len(Trim(staffName)) = 0 Or Len(Trim(dept)) = 0 Then + MsgBox "Please fill in for both Name and Department.", vbExclamation + Exit Sub + End If + + ' Check for duplicate names in the table + For checkRow = 1 To morningtbl.ListRows.Count + If UCase(Trim(morningtbl.ListRows(checkRow).Range.Cells(1, GetColumnIndex(morningtbl, "Name")).Value)) = staffName Then + MsgBox "This staff name already exists.", vbExclamation + Exit Sub + End If + Next checkRow + + ' Insert new row at the top of the MorningMainList table + Set newRow = morningtbl.ListRows.Add(AlwaysInsert:=True) + + ' Populate the new row with data using column names + With newRow.Range + .Cells(1, GetColumnIndex(morningtbl, "Name")).Value = staffName ' Name + .Cells(1, GetColumnIndex(morningtbl, "Department")).Value = dept ' Department + .Cells(1, GetColumnIndex(morningtbl, "Availability Type")).Value = availType ' Use entered Availability Type + .Cells(1, GetColumnIndex(morningtbl, "Duties Percentage (%)")).Value = Val(percentage) ' Duties Percentage + .Cells(1, GetColumnIndex(morningtbl, "Max Duties")).Value = 0 ' Temporary placeholder + .Cells(1, GetColumnIndex(morningtbl, "Duties Counter")).Value = 0 ' Default Duties Counter + End With + + ' Handle specific days workers by inserting into MorningSpecificDaysWorkingStaff table + If availType = "SPECIFIC DAYS" Then + Dim specificRow As ListRow + Set specificRow = specificDaysTbl.ListRows.Add(AlwaysInsert:=True) + With specificRow.Range + .Cells(1, GetColumnIndex(specificDaysTbl, "Name")).Value = staffName ' Name + .Cells(1, GetColumnIndex(specificDaysTbl, "Working Days")).Value = workDays ' Working Days + End With + End If + + ' Call CalculateMaxDuties to update Max Duties for the entire table + CalculateMaxDuties "MORNING" + + ' Update the newly added row with calculated Max Duties + With newRow.Range + Dim maxDutiesIndex As Long + maxDutiesIndex = GetColumnIndex(morningtbl, "Max Duties") + If maxDutiesIndex <> -1 Then + .Cells(1, maxDutiesIndex).Value = morningtbl.ListRows(1).Range.Cells(1, maxDutiesIndex).Value + Else + MsgBox "Column 'Max Duties' not found.", vbExclamation + newRow.Delete + Exit Sub + End If + End With + + ' Clear input + ws.Range("D5:D9").ClearContents + + MsgBox "Staff added and Max Duties calculated successfully!", vbInformation + Exit Sub + +ErrHandler: + MsgBox "An error occurred: " & Err.Description, vbCritical + If Not newRow Is Nothing Then newRow.Delete ' Clean up if row was added + Exit Sub +End Sub + +' Helper function to get column index safely +Private Function GetColumnIndex(tbl As ListObject, columnName As String) As Long + On Error Resume Next + GetColumnIndex = tbl.ListColumns(columnName).Index + If Err.Number <> 0 Then + MsgBox "Column '" & columnName & "' not found in table '" & tbl.Name & "'.", vbExclamation + GetColumnIndex = -1 + End If + On Error GoTo 0 +End Function + +' CalculateMaxDuties subroutine +Sub CalculateMaxDuties(dutyType As String) + Dim ws As Worksheet + Dim tbl As ListObject + 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 + + ' Set worksheet and table based on dutyType + Select Case UCase(dutyType) + Case "MORNING" + Set ws = ThisWorkbook.Sheets("Morning PersonnelList") + Set tbl = ws.ListObjects("MorningMainList") + Case "AFTERNOON" + Set ws = ThisWorkbook.Sheets("AfternoonPersonnelList") + Set tbl = ws.ListObjects("AfternoonMainList") + Case "AOH" + Set ws = ThisWorkbook.Sheets("AOH PersonnelList") + Set tbl = ws.ListObjects("AOHMainList") + Case "SAT_AOH" + Set ws = ThisWorkbook.Sheets("Sat AOH PersonnelList") + Set tbl = ws.ListObjects("SatAOHMainList") + Case Else + MsgBox "Invalid duty type. Use 'Morning', 'Afternoon', 'AOH', or 'Sat_AOH'.", vbExclamation + Exit Sub + End Select + + totalStaff = tbl.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 = tbl.ListRows(i).Range.Cells(GetColumnIndex(tbl, "Duties Percentage (%)")).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 for " & dutyType, vbExclamation + End If + End If + + ' Write results back to sheet + For i = 1 To totalStaff + tbl.ListRows(i).Range.Cells(GetColumnIndex(tbl, "Max Duties")).Value = rounded(i) + Next i + + Debug.Print "Max Duties calculated for " & dutyType & " with total duties: " & totalDuties & ", total staff: " & totalStaff +End Sub From df9af77acba40b4be82acf0755dee984575b204f Mon Sep 17 00:00:00 2001 From: Si Yu Lew <156303901+bananapielearnsjava@users.noreply.github.com> Date: Tue, 22 Jul 2025 15:06:18 +0800 Subject: [PATCH 3/6] Reprotect Sheet module --- VBA/VBA-Code_By_Modules/ReprotectSheet.bas | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) create mode 100644 VBA/VBA-Code_By_Modules/ReprotectSheet.bas diff --git a/VBA/VBA-Code_By_Modules/ReprotectSheet.bas b/VBA/VBA-Code_By_Modules/ReprotectSheet.bas new file mode 100644 index 0000000..a83499c --- /dev/null +++ b/VBA/VBA-Code_By_Modules/ReprotectSheet.bas @@ -0,0 +1,21 @@ +Attribute VB_Name = "ReprotectSheet" +Sub ReprotectSheet() + On Error GoTo ErrHandler + + Dim ws As Worksheet + Dim password As String + + ' the protection password + password = "nuslib2025" + + Set ws = ActiveSheet + + ' Reprotect the worksheet with password + ws.Protect password, DrawingObjects:=True, Contents:=True, Scenarios:=True + Exit Sub + +ErrHandler: + MsgBox "An error occurred while reprotecting the sheet: " & Err.Description, vbCritical + Exit Sub +End Sub + From fdcc19238bdc0d02a3401f08ed5b812efe688396 Mon Sep 17 00:00:00 2001 From: Si Yu Lew <156303901+bananapielearnsjava@users.noreply.github.com> Date: Tue, 22 Jul 2025 15:08:22 +0800 Subject: [PATCH 4/6] Delete Staff --- VBA/VBA-Code_By_Modules/DeleteStaff.bas | 144 ++++++++++++++++++++++++ 1 file changed, 144 insertions(+) create mode 100644 VBA/VBA-Code_By_Modules/DeleteStaff.bas diff --git a/VBA/VBA-Code_By_Modules/DeleteStaff.bas b/VBA/VBA-Code_By_Modules/DeleteStaff.bas new file mode 100644 index 0000000..6cc4ce8 --- /dev/null +++ b/VBA/VBA-Code_By_Modules/DeleteStaff.bas @@ -0,0 +1,144 @@ +Attribute VB_Name = "DeleteStaff" +Sub DeleteStaff() + On Error GoTo ErrHandler + + Dim ws As Worksheet + Dim tbl As ListObject + Dim selectedCell As Range + Dim rowToDelete As ListRow + Dim dutyType As String + Dim password As String + Dim specificDaysTbl As ListObject + Dim availIndex As Long + + ' Protection password + password = "nuslib2025" + + ' Authorization check + Dim userPassword As String + userPassword = InputBox("Enter the password to remove the staff:", "Authorization Required") + If userPassword <> password Then + MsgBox "Unauthorized access.", vbExclamation + Exit Sub + End If + + ' Duty type based on the active sheet + Select Case UCase(ActiveSheet.Name) + Case UCase("Loan Mail Box PersonnelList") + dutyType = "LOANMAILBOX" + Set ws = ThisWorkbook.Sheets("Loan Mail Box PersonnelList") + Set tbl = ws.ListObjects("LoanMailBoxMainList") + Set specificDaysTbl = ws.ListObjects("LoanMailBoxSpecificDaysWorkingStaff") + Case UCase("Morning PersonnelList") + dutyType = "MORNING" + Set ws = ThisWorkbook.Sheets("Morning PersonnelList") + Set tbl = ws.ListObjects("MorningMainList") + Set specificDaysTbl = ws.ListObjects("MorningSpecificDaysWorkingStaff") + Case UCase("Afternoon PersonnelList") + dutyType = "AFTERNOON" + Set ws = ThisWorkbook.Sheets("Afternoon PersonnelList") + Set tbl = ws.ListObjects("AfternoonMainList") + Set specificDaysTbl = ws.ListObjects("AfternoonSpecificDaysWorkingStaff") + Case UCase("AOH PersonnelList") + dutyType = "AOH" + Set ws = ThisWorkbook.Sheets("AOH PersonnelList") + Set tbl = ws.ListObjects("AOHMainList") + Set specificDaysTbl = ws.ListObjects("AOHSpecificDaysWorkingStaff") + Case UCase("Sat AOH PersonnelList") + dutyType = "SAT_AOH" + Set ws = ThisWorkbook.Sheets("Sat AOH PersonnelList") + Set tbl = ws.ListObjects("SatAOHMainList") + ' No specificDaysTbl for Sat AOH + Case Else + MsgBox "This sheet is not a personnel list. Please select a valid personnel list sheet.", vbExclamation + Exit Sub + End Select + + ' Validate worksheet and table + If ws Is Nothing Then + MsgBox "Worksheet for " & dutyType & " not found.", vbExclamation + Exit Sub + End If + If tbl Is Nothing Then + MsgBox "Table 'MainList' not found on '" & ws.Name & "'.", vbExclamation + Exit Sub + End If + + ' Get the selected cell + Set selectedCell = ActiveCell + If Not Intersect(selectedCell, tbl.Range) Is Nothing Then + ' Check if the selected cell is in the "Name" column + Dim nameIndex As Long + nameIndex = GetColumnIndex(tbl, "Name") + If nameIndex = -1 Then + MsgBox "Column 'Name' not found in '" & tbl.Name & "'.", vbExclamation + GoTo ReprotectAndExit + End If + If selectedCell.Column = tbl.Range.Cells(1, nameIndex).Column Then + ' Find the row in the table + Dim rowIndex As Long + rowIndex = selectedCell.row - tbl.Range.row + If rowIndex >= 1 And rowIndex <= tbl.ListRows.Count Then + Set rowToDelete = tbl.ListRows(rowIndex) + ' Get the Availability Type index + availIndex = GetColumnIndex(tbl, "Availability Type") + If availIndex = -1 Then + MsgBox "Column 'Availability Type' not found in '" & tbl.Name & "'.", vbExclamation + GoTo ReprotectAndExit + End If + ' Check if the staff is a Specific Days worker + If UCase(Trim(rowToDelete.Range.Cells(1, availIndex).Value)) = "SPECIFIC DAYS" And Not specificDaysTbl Is Nothing Then + Dim sdRow As ListRow + Dim sdNameIndex As Long + sdNameIndex = GetColumnIndex(specificDaysTbl, "Name") + If sdNameIndex = -1 Then + MsgBox "Column 'Name' not found in '" & specificDaysTbl.Name & "'.", vbExclamation + GoTo ReprotectAndExit + End If + ' Find and delete the corresponding row in SpecificDaysWorkingStaff + For Each sdRow In specificDaysTbl.ListRows + If UCase(Trim(sdRow.Range.Cells(1, sdNameIndex).Value)) = UCase(Trim(selectedCell.Value)) Then + sdRow.Delete + Exit For + End If + Next sdRow + End If + rowToDelete.Delete + CalculateMaxDuties.CalculateMaxDuties dutyType + MsgBox "Staff deleted and Max Duties recalculated successfully for " & dutyType & ".", vbInformation + Else + MsgBox "Selected cell is not within a valid table row.", vbExclamation + GoTo ReprotectAndExit + End If + Else + MsgBox "Please select a cell in the 'Name' column to delete the staff.", vbExclamation + GoTo ReprotectAndExit + End If + Else + MsgBox "Please select a cell within the table to delete a staff.", vbExclamation + GoTo ReprotectAndExit + End If + Exit Sub + +ReprotectAndExit: + ' Reprotect the worksheet + ws.Protect password, DrawingObjects:=True, Contents:=True, Scenarios:=True + Exit Sub + +ErrHandler: + MsgBox "An error occurred: " & Err.Description & vbCrLf & _ + "Line: " & Erl & vbCrLf & _ + "Duty Type: " & dutyType & vbCrLf & _ + "Worksheet: " & IIf(ws Is Nothing, "Not Set", ws.Name), vbCritical + ws.Protect password, DrawingObjects:=True, Contents:=True, Scenarios:=True ' Reprotect on error + Exit Sub +End Sub + +' Helper function to get column index +Private Function GetColumnIndex(tbl As ListObject, columnName As String) As Long + On Error Resume Next + GetColumnIndex = tbl.ListColumns(columnName).Index + If Err.Number <> 0 Then GetColumnIndex = -1 + On Error GoTo 0 +End Function + From 3449b0528abf352b31edcfeb446f903fef7577c7 Mon Sep 17 00:00:00 2001 From: Si Yu Lew <156303901+bananapielearnsjava@users.noreply.github.com> Date: Tue, 22 Jul 2025 18:12:35 +0800 Subject: [PATCH 5/6] Updated Delete Staff script with table protected as of 220725 18:12pm --- VBA/VBA-Code_By_Modules/Delete Staff.bas | 158 +++++++++++++++++++++++ 1 file changed, 158 insertions(+) create mode 100644 VBA/VBA-Code_By_Modules/Delete Staff.bas diff --git a/VBA/VBA-Code_By_Modules/Delete Staff.bas b/VBA/VBA-Code_By_Modules/Delete Staff.bas new file mode 100644 index 0000000..2de0b18 --- /dev/null +++ b/VBA/VBA-Code_By_Modules/Delete Staff.bas @@ -0,0 +1,158 @@ +Attribute VB_Name = "DeleteStaff" +Sub DeleteStaff() + On Error GoTo ErrHandler + + Dim ws As Worksheet + Dim tbl As ListObject + Dim selectedCell As Range + Dim rowToDelete As ListRow + Dim dutyType As String + Dim specificDaysTbl As ListObject + Dim availIndex As Long + + ' Set the active worksheet + Set ws = ActiveSheet + + ' Determine the duty type based on the active sheet + Select Case UCase(ws.Name) + Case UCase("Loan Mail Box PersonnelList") + dutyType = "LOANMAILBOX" + Set tbl = ws.ListObjects("LoanMailBoxMainList") + Set specificDaysTbl = ws.ListObjects("LoanMailBoxSpecificDaysWorkingStaff") + Case UCase("Morning PersonnelList") + dutyType = "MORNING" + Set tbl = ws.ListObjects("MorningMainList") + Set specificDaysTbl = ws.ListObjects("MorningSpecificDaysWorkingStaff") + Case UCase("Afternoon PersonnelList") + dutyType = "AFTERNOON" + Set tbl = ws.ListObjects("AfternoonMainList") + Set specificDaysTbl = ws.ListObjects("AfternoonSpecificDaysWorkingStaff") + Case UCase("AOH PersonnelList") + dutyType = "AOH" + Set tbl = ws.ListObjects("AOHMainList") + Set specificDaysTbl = ws.ListObjects("AOHSpecificDaysWorkingStaff") + Case UCase("Sat AOH PersonnelList") + dutyType = "SAT_AOH" + Set tbl = ws.ListObjects("SatAOHMainList") + ' No specificDaysTbl for Sat AOH + Case Else + MsgBox "This sheet is not a personnel list. Please select a valid personnel list sheet.", vbExclamation + Exit Sub + End Select + + ' Validate worksheet and table + If ws Is Nothing Then + MsgBox "Worksheet for " & dutyType & " not found.", vbExclamation + Exit Sub + End If + If tbl Is Nothing Then + MsgBox "Table 'MainList' not found on '" & ws.Name & "'.", vbExclamation + Exit Sub + End If + + ' Unprotect the worksheet (unlock) + ws.Unprotect + + ' Get the selected cell + Set selectedCell = ActiveCell + If Not Intersect(selectedCell, tbl.Range) Is Nothing Then + ' Check if the selected cell is in the "Name" column + Dim nameIndex As Long + nameIndex = GetColumnIndex(tbl, "Name") + If nameIndex = -1 Then + MsgBox "Column 'Name' not found in '" & tbl.Name & "'.", vbExclamation + GoTo ReprotectAndExit + End If + If selectedCell.Column <> tbl.Range.Cells(1, nameIndex).Column Then + MsgBox "Please select a cell in the 'Name' column to delete the staff.", vbExclamation + GoTo ReprotectAndExit + End If + + ' Find the row in the table + Dim rowIndex As Long + rowIndex = selectedCell.row - tbl.Range.row + If rowIndex > 0 And rowIndex <= tbl.ListRows.Count Then + Set rowToDelete = tbl.ListRows(rowIndex) + ' Get the Availability Type index + availIndex = GetColumnIndex(tbl, "Availability Type") + If availIndex = -1 Then + MsgBox "Column 'Availability Type' not found in '" & tbl.Name & "'.", vbExclamation + GoTo ReprotectAndExit + End If + + ' Clear filters if any + If tbl.ShowAutoFilter Then + tbl.AutoFilter.ShowAllData + End If + If Not specificDaysTbl Is Nothing And specificDaysTbl.ShowAutoFilter Then + specificDaysTbl.AutoFilter.ShowAllData + End If + + ' Check if the staff is a Specific Days worker + If UCase(Trim(rowToDelete.Range.Cells(1, availIndex).Value)) = "SPECIFIC DAYS" And Not specificDaysTbl Is Nothing Then + Dim sdRow As ListRow + Dim sdNameIndex As Long + sdNameIndex = GetColumnIndex(specificDaysTbl, "Name") + If sdNameIndex = -1 Then + MsgBox "Column 'Name' not found in '" & specificDaysTbl.Name & "'.", vbExclamation + GoTo ReprotectAndExit + End If + ' Clear filters on specific days table + If specificDaysTbl.ShowAutoFilter Then + specificDaysTbl.AutoFilter.ShowAllData + End If + ' Find and delete the corresponding row in SpecificDaysWorkingStaff + For Each sdRow In specificDaysTbl.ListRows + If UCase(Trim(sdRow.Range.Cells(1, sdNameIndex).Value)) = UCase(Trim(selectedCell.Value)) Then + sdRow.Delete + Exit For + End If + Next sdRow + End If + + ' Delete the row from the main table + rowToDelete.Delete + CalculateMaxDuties.CalculateMaxDuties dutyType + MsgBox "Staff deleted and Max Duties recalculated successfully for " & dutyType & ".", vbInformation + GoTo ReprotectAndExit + Else + MsgBox "Selected cell is not within a valid table row.", vbExclamation + GoTo ReprotectAndExit + End If + Else + MsgBox "Please select a cell within the main table to delete a staff.", vbExclamation + GoTo ReprotectAndExit + End If + Exit Sub + +ReprotectAndExit: + ' Reprotect the worksheet and lock table ranges + With ws + If Not tbl Is Nothing Then + .ListObjects(tbl.Name).Range.Locked = True + End If + If Not specificDaysTbl Is Nothing Then + .ListObjects(specificDaysTbl.Name).Range.Locked = True + End If + .Range("D5:D9").Locked = False ' keep data entry remains unlocked + .Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, _ + AllowFiltering:=True, AllowSorting:=True, AllowUsingPivotTables:=True + End With + Exit Sub + +ErrHandler: + MsgBox "An error occurred: " & Err.Description & vbCrLf & _ + "Line: " & Erl & vbCrLf & _ + "Duty Type: " & dutyType & vbCrLf & _ + "Worksheet: " & IIf(ws Is Nothing, "Not Set", ws.Name), vbCritical + GoTo ReprotectAndExit +End Sub + +' Helper function to get column index +Private Function GetColumnIndex(tbl As ListObject, columnName As String) As Long + On Error Resume Next + GetColumnIndex = tbl.ListColumns(columnName).Index + If Err.Number <> 0 Then GetColumnIndex = -1 + On Error GoTo 0 +End Function + From 86efeed0fb4db00bb42eae6a6f28460e1b99f2c2 Mon Sep 17 00:00:00 2001 From: Si Yu Lew <156303901+bananapielearnsjava@users.noreply.github.com> Date: Mon, 28 Jul 2025 14:51:43 +0800 Subject: [PATCH 6/6] Swap Staff with password authentication --- VBA/VBA-Code_By_Modules/Swap.bas | 240 +++++++++++++++++++++++++------ 1 file changed, 196 insertions(+), 44 deletions(-) diff --git a/VBA/VBA-Code_By_Modules/Swap.bas b/VBA/VBA-Code_By_Modules/Swap.bas index b4a6ac9..1cb51be 100644 --- a/VBA/VBA-Code_By_Modules/Swap.bas +++ b/VBA/VBA-Code_By_Modules/Swap.bas @@ -1,59 +1,211 @@ Attribute VB_Name = "Swap" +Option Explicit + Const PASSWORD As String = "swapswap" +' 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 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 + Dim enteredPassword As String + + enteredPassword = InputBox("Please enter the password to proceed with the swap:", "Password Authentication") + If enteredPassword <> PASSWORD Then + MsgBox "Incorrect password. Swap operation cancelled.", vbCritical + Exit Sub + End If + + InitializeWorksheets 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(LMB_COL, MOR_COL, AFT_COL, AOH_COL, SAT_AOH_COL1, SAT_AOH_COL2) + 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 on date " & wsRoster.Cells(r, DATE_COL).Value & ". Swap not allowed.", vbExclamation + Else + Dim nameExists As Boolean + CheckNewNameExists wsRoster, r, slotCols, newName, nameExists + If nameExists Then + DisplayError "Error: " & newName & " already exists on date " & wsRoster.Cells(r, DATE_COL).Value & ". Swap not allowed.", vbExclamation + Else + PerformSwap wsRoster, r, slotCols, oriName, newName, wsPersonnel + MsgBox "Swap completed.", vbInformation + End If + End If + Next dateCell + + wsRoster.Activate +End Sub - Set wsRoster = Sheets("MasterCopy") +' Initialize worksheet references +Private Sub InitializeWorksheets(wsPersonnel As Worksheet, wsSwap As Worksheet) + Set wsRoster = Sheets("Roster") 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 + +' 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 cells in Column A +' 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 B)", 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.count = 1 Or dateRange.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 - - 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 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 + Dim currStaff As String + oriNameFound = False + For Each col In slotCols + cellValue = wsRoster.Cells(r, col).Value + If InStr(cellValue, vbNewLine) > 0 Then + currStaff = UCase(Trim(Replace(Split(cellValue, vbNewLine)(0), Chr(160), " "))) + Debug.Print "--multiple value" + Else + currStaff = UCase(Trim(cellValue)) + End If + + Debug.Print "Checking slot " & col & ": " & currStaff & " vs " & oriName + + If currStaff = oriName Then + oriNameFound = True + Exit For + End If + Next col +End Sub - MsgBox "Swap complete.", vbInformation +' 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 + +' 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 +