From 8ba6cd5c96837ade1991453ec78b386dba455db0 Mon Sep 17 00:00:00 2001 From: Casielim Date: Tue, 22 Jul 2025 21:47:00 +0800 Subject: [PATCH 01/12] Duplicate system roster --- .../DuplicateSystemRoster.bas | 27 +++++++++++++++++++ 1 file changed, 27 insertions(+) create mode 100644 VBA/VBA-Code_By_Modules/DuplicateSystemRoster.bas diff --git a/VBA/VBA-Code_By_Modules/DuplicateSystemRoster.bas b/VBA/VBA-Code_By_Modules/DuplicateSystemRoster.bas new file mode 100644 index 0000000..7891add --- /dev/null +++ b/VBA/VBA-Code_By_Modules/DuplicateSystemRoster.bas @@ -0,0 +1,27 @@ +Attribute VB_Name = "DuplicateSystemRoster" +Sub DuplicateSystemRoster() + Dim srcSheet As Worksheet + Dim copySheet As Worksheet + Dim sheetName As String + + Set wsRoster = Sheets("Roster") + Set srcSheet = wsRoster + sheetName = "SystemRoster_" & Format(Now, "yymmdd_hhnn") + + 'Copy the whole sheet + srcSheet.Copy After:=Sheets(Sheets.Count) + Set copySheet = ActiveSheet + copySheet.Name = sheetName + + With srcSheet.UsedRange + copySheet.Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value + Application.CutCopyMode = False + End With + + copySheet.Protect password:="nuslib2017@52", _ + AllowSorting:=True, _ + AllowFiltering:=True + + wsRoster.Activate + +End Sub From 882aa4a94df9e6aef0ac78a39cd369f00e7bb6a4 Mon Sep 17 00:00:00 2001 From: Casielim Date: Tue, 22 Jul 2025 21:47:26 +0800 Subject: [PATCH 02/12] Duplicate actual roster --- .../DuplicateActualRoster.bas | 25 +++++++++++++++++++ 1 file changed, 25 insertions(+) create mode 100644 VBA/VBA-Code_By_Modules/DuplicateActualRoster.bas diff --git a/VBA/VBA-Code_By_Modules/DuplicateActualRoster.bas b/VBA/VBA-Code_By_Modules/DuplicateActualRoster.bas new file mode 100644 index 0000000..220eebe --- /dev/null +++ b/VBA/VBA-Code_By_Modules/DuplicateActualRoster.bas @@ -0,0 +1,25 @@ +Attribute VB_Name = "DuplicateActualRoster" +Sub DuplicateActualRoster() + Dim srcSheet As Worksheet + Dim copySheet As Worksheet + Dim sheetName As String + + Set srcSheet = Sheets("Roster") + sheetName = "ActualRoster_" & Format(Now, "yyyymmdd_hhnn") + + srcSheet.Copy After:=Sheets(Sheets.Count) + Set copySheet = ActiveSheet + copySheet.Name = sheetName + + With srcSheet.UsedRange + .Copy Destination:=copySheet.Range("A1") + End With + + copySheet.Protect password:="nuslib2017@52", _ + AllowSorting:=True, _ + AllowFiltering:=True + + + srcSheet.Activate + +End Sub From 07f37badcf3cba002f0d74e096b9f850257670f8 Mon Sep 17 00:00:00 2001 From: Casielim Date: Wed, 23 Jul 2025 11:48:09 +0800 Subject: [PATCH 03/12] Update duplicate roster to allow cell formatting --- VBA/VBA-Code_By_Modules/DuplicateActualRoster.bas | 4 +++- VBA/VBA-Code_By_Modules/DuplicateSystemRoster.bas | 5 ++++- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/VBA/VBA-Code_By_Modules/DuplicateActualRoster.bas b/VBA/VBA-Code_By_Modules/DuplicateActualRoster.bas index 220eebe..13da495 100644 --- a/VBA/VBA-Code_By_Modules/DuplicateActualRoster.bas +++ b/VBA/VBA-Code_By_Modules/DuplicateActualRoster.bas @@ -17,9 +17,11 @@ Sub DuplicateActualRoster() copySheet.Protect password:="nuslib2017@52", _ AllowSorting:=True, _ - AllowFiltering:=True + AllowFiltering:=True, _ + AllowFormattingCells:=True srcSheet.Activate End Sub + diff --git a/VBA/VBA-Code_By_Modules/DuplicateSystemRoster.bas b/VBA/VBA-Code_By_Modules/DuplicateSystemRoster.bas index 7891add..0e63068 100644 --- a/VBA/VBA-Code_By_Modules/DuplicateSystemRoster.bas +++ b/VBA/VBA-Code_By_Modules/DuplicateSystemRoster.bas @@ -20,8 +20,11 @@ Sub DuplicateSystemRoster() copySheet.Protect password:="nuslib2017@52", _ AllowSorting:=True, _ - AllowFiltering:=True + AllowFiltering:=True, _ + AllowFormattingCells:=True wsRoster.Activate End Sub + + From 516e3ab1ca6eed03da8e6d7c336e11d74f3dc098 Mon Sep 17 00:00:00 2001 From: Casielim Date: Wed, 23 Jul 2025 17:13:36 +0800 Subject: [PATCH 04/12] Report for morning slot analysis --- VBA/VBA-Code_By_Modules/Report.bas | 68 +++++++++++++++++ VBA/VBA-Code_By_Modules/Report1.bas | 109 ++++++++++++++++++++++++++++ 2 files changed, 177 insertions(+) create mode 100644 VBA/VBA-Code_By_Modules/Report.bas create mode 100644 VBA/VBA-Code_By_Modules/Report1.bas diff --git a/VBA/VBA-Code_By_Modules/Report.bas b/VBA/VBA-Code_By_Modules/Report.bas new file mode 100644 index 0000000..9642562 --- /dev/null +++ b/VBA/VBA-Code_By_Modules/Report.bas @@ -0,0 +1,68 @@ +Attribute VB_Name = "Report" +Sub GenerateMorningShiftAnalysis1() + Dim wsPersonnel As Worksheet + Dim wsAnalysis As Worksheet + Dim tbl As ListObject + Dim nameList As Range, dutyCounterList As Range + Dim lastRow As Long, i As Long + Dim dict As Object + Dim empName As String + Dim MOR_COL As Long: MOR_COL = 6 ' Morning Shift column + Dim START_ROW As Long: START_ROW = 6 ' Data start row + + ' Set sheets + Set wsPersonnel = Sheets("Morning PersonnelList") + + ' Create or clear analysis sheet + On Error Resume Next + Application.DisplayAlerts = False + Sheets("MorningAnalysis").Delete + Application.DisplayAlerts = True + On Error GoTo 0 + Set wsAnalysis = Sheets.Add(After:=Sheets(Sheets.Count)) + wsAnalysis.Name = "MorningAnalysis" + + ' Get the table + Set tbl = wsPersonnel.ListObjects("MorningMainList") + Set nameList = tbl.ListColumns("Name").DataBodyRange + Set dutyCounterList = tbl.ListColumns("Duties Counter").DataBodyRange + + ' Header row for analysis + With wsAnalysis + .Range("A1").Value = "Name" + .Range("B1").Value = "System Counter" + .Range("C1").Value = "Actual Counter" + .Range("D1").Value = "Difference" + End With + + ' Copy names and system counter to analysis sheet + For i = 1 To nameList.Rows.Count + wsAnalysis.Cells(i + 1, 1).Value = nameList.Cells(i, 1).Value + wsAnalysis.Cells(i + 1, 2).Value = dutyCounterList.Cells(i, 1).Value + Next i + + ' Create dictionary to count actual appearances + Set dict = CreateObject("Scripting.Dictionary") + For i = 1 To nameList.Rows.Count + empName = nameList.Cells(i, 1).Value + dict(empName) = 0 + Next i + + ' Walk through the roster and count appearances + lastRow = wsRoster.Cells(wsRoster.Rows.Count, MOR_COL).End(xlUp).row + For i = START_ROW To lastRow + empName = Trim(wsRoster.Cells(i, MOR_COL).Value) + If dict.exists(empName) Then + dict(empName) = dict(empName) + 1 + End If + Next i + + ' Write actual counter and difference to sheet + For i = 2 To nameList.Rows.Count + 1 + empName = wsAnalysis.Cells(i, 1).Value + wsAnalysis.Cells(i, 3).Value = dict(empName) ' Actual Counter + wsAnalysis.Cells(i, 4).FormulaR1C1 = "=RC[-2]-RC[-1]" ' System - Actual + Next i + + MsgBox "Morning shift analysis generated in 'MorningAnalysis' sheet.", vbInformation +End Sub diff --git a/VBA/VBA-Code_By_Modules/Report1.bas b/VBA/VBA-Code_By_Modules/Report1.bas new file mode 100644 index 0000000..fe1953d --- /dev/null +++ b/VBA/VBA-Code_By_Modules/Report1.bas @@ -0,0 +1,109 @@ +Attribute VB_Name = "rEPORT1" +Sub GenerateMorningShiftAnalysis() + Dim wsPersonnel As Worksheet + Dim wsAnalysis As Worksheet + Dim wsRosterCopy As Worksheet + Dim tbl As ListObject + Dim nameList As Range + Dim dutyCounterList As Range + Dim lastRow As Long, i As Long + Dim dict As Object + Dim empName As String + Dim latestRosterName As String + Dim sht As Worksheet + Dim newestDate As Date + Dim match As Object + Set match = CreateObject("Scripting.Dictionary") + + ' Find latest duplicated actual roster sheet + newestDate = 0 + For Each sht In ThisWorkbook.Sheets + If sht.Name Like "ActualRoster_*" Then + Dim dtPart As String + dtPart = Replace(Mid(sht.Name, 14), "_", " ") ' Extract "yyyymmdd hhnn" + On Error Resume Next + Dim parsedDate As Date + parsedDate = CDate(Left(dtPart, 4) & "/" & Mid(dtPart, 5, 2) & "/" & Mid(dtPart, 7, 2) & " " & Mid(dtPart, 10, 2) & ":" & Mid(dtPart, 12, 2)) + If Err.Number = 0 Then + If parsedDate > newestDate Then + newestDate = parsedDate + latestRosterName = sht.Name + End If + End If + On Error GoTo 0 + End If + Next sht + + Debug.Print "latest actual roster:" & latestRosterName + + If latestRosterName = "" Then + MsgBox "No ActualRoster_* sheet found.", vbExclamation + Exit Sub + End If + + Set wsRosterCopy = Sheets(latestRosterName) + Set wsPersonnel = Sheets("Morning PersonnelList") + + ' Create or clear analysis sheet + On Error Resume Next + Application.DisplayAlerts = False + Sheets("MorningAnalysis").Delete + Application.DisplayAlerts = True + On Error GoTo 0 + Set wsAnalysis = Sheets.Add(After:=Sheets(Sheets.Count)) + wsAnalysis.Name = "MorningAnalysis" + + ' Get the personnel table + Set tbl = wsPersonnel.ListObjects("MorningMainList") + Set nameList = tbl.ListColumns("Name").DataBodyRange + Set dutyCounterList = tbl.ListColumns("Duties Counter").DataBodyRange + + ' Header row + With wsAnalysis + .Range("A1").Value = "Name" + .Range("B1").Value = "System Counter" + .Range("C1").Value = "Actual Counter" + .Range("D1").Value = "Difference" + End With + + ' Copy names and system counters + For i = 1 To nameList.Rows.Count + wsAnalysis.Cells(i + 1, 1).Value = nameList.Cells(i, 1).Value + wsAnalysis.Cells(i + 1, 2).Value = dutyCounterList.Cells(i, 1).Value + Next i + + ' Create dictionary to count actual appearances + Set dict = CreateObject("Scripting.Dictionary") + For i = 1 To nameList.Rows.Count + empName = nameList.Cells(i, 1).Value + dict(empName) = 0 + Next i + + ' Count appearances (ignoring strikethrough and multiple lines) + 'lastRow = wsRoster.Cells(wsRoster.Rows.Count, MOR_COL).End(xlUp).row + Dim cell As Range, firstLine As String + For i = START_ROW To 186 'LAST_ROW_ROSTER + Set cell = wsRosterCopy.Cells(i, MOR_COL) + cellValue = cell.Value + If InStr(cellValue, vbNewLine) > 0 Then + currStaff = UCase(Trim(Replace(Split(cellValue, vbNewLine)(0), Chr(160), " "))) + Else + currStaff = UCase(Trim(cellValue)) + End If + + If dict.exists(currStaff) Then + dict(currStaff) = dict(currStaff) + 1 + Debug.Print currStaff; ": " & dict(currStaff) + End If + Next i + + ' Write results + For i = 2 To nameList.Rows.Count + 1 + empName = UCase(Trim(wsAnalysis.Cells(i, 1).Value)) + wsAnalysis.Cells(i, 3).Value = dict(empName) ' Actual Counter + wsAnalysis.Cells(i, 4).FormulaR1C1 = "=RC[-2]-RC[-1]" ' System - Actual + Next i + + MsgBox "Morning shift analysis generated using '" & latestRosterName & "'.", vbInformation +End Sub + From 3c379304781558bdd896ec2ed49f7f0fe6aab5ae Mon Sep 17 00:00:00 2001 From: Casielim Date: Wed, 23 Jul 2025 21:17:53 +0800 Subject: [PATCH 05/12] Report 1 --- VBA/VBA-Code_By_Modules/Report1.bas | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VBA/VBA-Code_By_Modules/Report1.bas b/VBA/VBA-Code_By_Modules/Report1.bas index fe1953d..b4c3fbb 100644 --- a/VBA/VBA-Code_By_Modules/Report1.bas +++ b/VBA/VBA-Code_By_Modules/Report1.bas @@ -101,7 +101,7 @@ Sub GenerateMorningShiftAnalysis() For i = 2 To nameList.Rows.Count + 1 empName = UCase(Trim(wsAnalysis.Cells(i, 1).Value)) wsAnalysis.Cells(i, 3).Value = dict(empName) ' Actual Counter - wsAnalysis.Cells(i, 4).FormulaR1C1 = "=RC[-2]-RC[-1]" ' System - Actual + wsAnalysis.Cells(i, 4).FormulaR1C1 = "=RC[-1]-RC[-2]" ' Actual - System Next i MsgBox "Morning shift analysis generated using '" & latestRosterName & "'.", vbInformation From 4bcc1962aa0c325c6bbfaee59229222e1bfbfffc Mon Sep 17 00:00:00 2001 From: Casielim Date: Wed, 23 Jul 2025 21:29:55 +0800 Subject: [PATCH 06/12] Report1 v2 --- VBA/VBA-Code_By_Modules/Report1.bas | 61 +++++++++++++++++------------ 1 file changed, 35 insertions(+), 26 deletions(-) diff --git a/VBA/VBA-Code_By_Modules/Report1.bas b/VBA/VBA-Code_By_Modules/Report1.bas index b4c3fbb..b480c7d 100644 --- a/VBA/VBA-Code_By_Modules/Report1.bas +++ b/VBA/VBA-Code_By_Modules/Report1.bas @@ -12,15 +12,17 @@ Sub GenerateMorningShiftAnalysis() Dim latestRosterName As String Dim sht As Worksheet Dim newestDate As Date - Dim match As Object - Set match = CreateObject("Scripting.Dictionary") + Dim START_ROW As Long: START_ROW = 6 + Dim MOR_COL As Long: MOR_COL = 6 + Dim cell As Range, cellValue As String, currStaff As String + Dim nextRow As Long - ' Find latest duplicated actual roster sheet + ' Find latest ActualRoster_* sheet newestDate = 0 For Each sht In ThisWorkbook.Sheets If sht.Name Like "ActualRoster_*" Then Dim dtPart As String - dtPart = Replace(Mid(sht.Name, 14), "_", " ") ' Extract "yyyymmdd hhnn" + dtPart = Replace(Mid(sht.Name, 14), "_", " ") On Error Resume Next Dim parsedDate As Date parsedDate = CDate(Left(dtPart, 4) & "/" & Mid(dtPart, 5, 2) & "/" & Mid(dtPart, 7, 2) & " " & Mid(dtPart, 10, 2) & ":" & Mid(dtPart, 12, 2)) @@ -34,8 +36,6 @@ Sub GenerateMorningShiftAnalysis() End If Next sht - Debug.Print "latest actual roster:" & latestRosterName - If latestRosterName = "" Then MsgBox "No ActualRoster_* sheet found.", vbExclamation Exit Sub @@ -53,7 +53,7 @@ Sub GenerateMorningShiftAnalysis() Set wsAnalysis = Sheets.Add(After:=Sheets(Sheets.Count)) wsAnalysis.Name = "MorningAnalysis" - ' Get the personnel table + ' Get personnel table Set tbl = wsPersonnel.ListObjects("MorningMainList") Set nameList = tbl.ListColumns("Name").DataBodyRange Set dutyCounterList = tbl.ListColumns("Duties Counter").DataBodyRange @@ -67,41 +67,50 @@ Sub GenerateMorningShiftAnalysis() End With ' Copy names and system counters - For i = 1 To nameList.Rows.Count - wsAnalysis.Cells(i + 1, 1).Value = nameList.Cells(i, 1).Value - wsAnalysis.Cells(i + 1, 2).Value = dutyCounterList.Cells(i, 1).Value - Next i - - ' Create dictionary to count actual appearances Set dict = CreateObject("Scripting.Dictionary") For i = 1 To nameList.Rows.Count - empName = nameList.Cells(i, 1).Value + empName = UCase(Trim(nameList.Cells(i, 1).Value)) + wsAnalysis.Cells(i + 1, 1).Value = empName + wsAnalysis.Cells(i + 1, 2).Value = dutyCounterList.Cells(i, 1).Value dict(empName) = 0 Next i - ' Count appearances (ignoring strikethrough and multiple lines) - 'lastRow = wsRoster.Cells(wsRoster.Rows.Count, MOR_COL).End(xlUp).row - Dim cell As Range, firstLine As String - For i = START_ROW To 186 'LAST_ROW_ROSTER + ' Count actual appearances + For i = START_ROW To 186 Set cell = wsRosterCopy.Cells(i, MOR_COL) cellValue = cell.Value + If InStr(cellValue, vbNewLine) > 0 Then currStaff = UCase(Trim(Replace(Split(cellValue, vbNewLine)(0), Chr(160), " "))) Else currStaff = UCase(Trim(cellValue)) End If - - If dict.exists(currStaff) Then - dict(currStaff) = dict(currStaff) + 1 - Debug.Print currStaff; ": " & dict(currStaff) + + If Len(currStaff) > 0 Then + If dict.exists(currStaff) Then + dict(currStaff) = dict(currStaff) + 1 + Else + ' New staff: add to bottom of analysis + nextRow = wsAnalysis.Cells(wsAnalysis.Rows.Count, 1).End(xlUp).row + 1 + wsAnalysis.Cells(nextRow, 1).Value = currStaff + wsAnalysis.Cells(nextRow, 2).Value = 0 + wsAnalysis.Cells(nextRow, 3).Value = 1 + wsAnalysis.Cells(nextRow, 4).FormulaR1C1 = "=RC[-1]-RC[-2]" + dict(currStaff) = 1 + + ' Highlight the new staff row in yellow + wsAnalysis.Range(wsAnalysis.Cells(nextRow, 1), wsAnalysis.Cells(nextRow, 4)).Interior.Color = RGB(255, 255, 153) + End If End If Next i - ' Write results - For i = 2 To nameList.Rows.Count + 1 + ' Fill actual counters and compute differences + For i = 2 To wsAnalysis.Cells(wsAnalysis.Rows.Count, 1).End(xlUp).row empName = UCase(Trim(wsAnalysis.Cells(i, 1).Value)) - wsAnalysis.Cells(i, 3).Value = dict(empName) ' Actual Counter - wsAnalysis.Cells(i, 4).FormulaR1C1 = "=RC[-1]-RC[-2]" ' Actual - System + If dict.exists(empName) Then + wsAnalysis.Cells(i, 3).Value = dict(empName) + wsAnalysis.Cells(i, 4).FormulaR1C1 = "=RC[-1]-RC[-2]" + End If Next i MsgBox "Morning shift analysis generated using '" & latestRosterName & "'.", vbInformation From 64682e59b59a5c9e99f3f390d7bfc8b2d18a9eaf Mon Sep 17 00:00:00 2001 From: Casielim Date: Wed, 23 Jul 2025 21:30:36 +0800 Subject: [PATCH 07/12] Add percentage diff and make it a table --- VBA/VBA-Code_By_Modules/Report1.bas | 52 ++++++++++++++++++----------- 1 file changed, 33 insertions(+), 19 deletions(-) diff --git a/VBA/VBA-Code_By_Modules/Report1.bas b/VBA/VBA-Code_By_Modules/Report1.bas index b480c7d..f882996 100644 --- a/VBA/VBA-Code_By_Modules/Report1.bas +++ b/VBA/VBA-Code_By_Modules/Report1.bas @@ -15,7 +15,7 @@ Sub GenerateMorningShiftAnalysis() Dim START_ROW As Long: START_ROW = 6 Dim MOR_COL As Long: MOR_COL = 6 Dim cell As Range, cellValue As String, currStaff As String - Dim nextRow As Long + Dim nextRow As Long, tableStartRow As Long ' Find latest ActualRoster_* sheet newestDate = 0 @@ -53,29 +53,36 @@ Sub GenerateMorningShiftAnalysis() Set wsAnalysis = Sheets.Add(After:=Sheets(Sheets.Count)) wsAnalysis.Name = "MorningAnalysis" - ' Get personnel table - Set tbl = wsPersonnel.ListObjects("MorningMainList") - Set nameList = tbl.ListColumns("Name").DataBodyRange - Set dutyCounterList = tbl.ListColumns("Duties Counter").DataBodyRange + ' Write title + wsAnalysis.Range("A1").Value = "Morning Slot Analysis" + wsAnalysis.Range("A1").Font.Bold = True + wsAnalysis.Range("A1").Font.Size = 14 + tableStartRow = 3 ' header starts here ' Header row With wsAnalysis - .Range("A1").Value = "Name" - .Range("B1").Value = "System Counter" - .Range("C1").Value = "Actual Counter" - .Range("D1").Value = "Difference" + .Range("A" & tableStartRow).Value = "Name" + .Range("B" & tableStartRow).Value = "System Counter" + .Range("C" & tableStartRow).Value = "Actual Counter" + .Range("D" & tableStartRow).Value = "Difference" + .Range("E" & tableStartRow).Value = "% Difference" End With - ' Copy names and system counters + ' Get personnel table + Set tbl = wsPersonnel.ListObjects("MorningMainList") + Set nameList = tbl.ListColumns("Name").DataBodyRange + Set dutyCounterList = tbl.ListColumns("Duties Counter").DataBodyRange + + ' Create dictionary and fill initial system counter Set dict = CreateObject("Scripting.Dictionary") For i = 1 To nameList.Rows.Count empName = UCase(Trim(nameList.Cells(i, 1).Value)) - wsAnalysis.Cells(i + 1, 1).Value = empName - wsAnalysis.Cells(i + 1, 2).Value = dutyCounterList.Cells(i, 1).Value + wsAnalysis.Cells(i + tableStartRow, 1).Value = empName + wsAnalysis.Cells(i + tableStartRow, 2).Value = dutyCounterList.Cells(i, 1).Value dict(empName) = 0 Next i - ' Count actual appearances + ' Count actual appearances from roster For i = START_ROW To 186 Set cell = wsRosterCopy.Cells(i, MOR_COL) cellValue = cell.Value @@ -86,33 +93,40 @@ Sub GenerateMorningShiftAnalysis() currStaff = UCase(Trim(cellValue)) End If - If Len(currStaff) > 0 Then + If Len(currStaff) > 0 And currStaff <> "CLOSED" Then If dict.exists(currStaff) Then dict(currStaff) = dict(currStaff) + 1 Else - ' New staff: add to bottom of analysis + ' New staff found nextRow = wsAnalysis.Cells(wsAnalysis.Rows.Count, 1).End(xlUp).row + 1 wsAnalysis.Cells(nextRow, 1).Value = currStaff wsAnalysis.Cells(nextRow, 2).Value = 0 wsAnalysis.Cells(nextRow, 3).Value = 1 wsAnalysis.Cells(nextRow, 4).FormulaR1C1 = "=RC[-1]-RC[-2]" + wsAnalysis.Cells(nextRow, 5).FormulaR1C1 = "=IF(RC[-3]=0,"""",RC[-1]/RC[-3]*100)" dict(currStaff) = 1 - ' Highlight the new staff row in yellow - wsAnalysis.Range(wsAnalysis.Cells(nextRow, 1), wsAnalysis.Cells(nextRow, 4)).Interior.Color = RGB(255, 255, 153) + ' Highlight new row + wsAnalysis.Range(wsAnalysis.Cells(nextRow, 1), wsAnalysis.Cells(nextRow, 5)).Interior.Color = RGB(255, 255, 153) End If End If Next i - ' Fill actual counters and compute differences - For i = 2 To wsAnalysis.Cells(wsAnalysis.Rows.Count, 1).End(xlUp).row + ' Fill actual count and compute difference + percentage + For i = tableStartRow + 1 To wsAnalysis.Cells(wsAnalysis.Rows.Count, 1).End(xlUp).row empName = UCase(Trim(wsAnalysis.Cells(i, 1).Value)) If dict.exists(empName) Then wsAnalysis.Cells(i, 3).Value = dict(empName) wsAnalysis.Cells(i, 4).FormulaR1C1 = "=RC[-1]-RC[-2]" + wsAnalysis.Cells(i, 5).FormulaR1C1 = "=IF(RC[-3]=0,"""",RC[-1]/RC[-3]*100)" End If Next i + ' Format as Table + Dim tableRange As Range + Set tableRange = wsAnalysis.Range("A" & tableStartRow & ":E" & wsAnalysis.Cells(wsAnalysis.Rows.Count, 1).End(xlUp).row) + wsAnalysis.ListObjects.Add(xlSrcRange, tableRange, , xlYes).Name = "MorningShiftTable" + MsgBox "Morning shift analysis generated using '" & latestRosterName & "'.", vbInformation End Sub From 4c16878480240e876b96e73d917146597dbdc324 Mon Sep 17 00:00:00 2001 From: Casielim Date: Wed, 23 Jul 2025 22:11:16 +0800 Subject: [PATCH 08/12] Tidy and format the table --- VBA/VBA-Code_By_Modules/Report1.bas | 37 +++++++++++++++++++++++++---- 1 file changed, 33 insertions(+), 4 deletions(-) diff --git a/VBA/VBA-Code_By_Modules/Report1.bas b/VBA/VBA-Code_By_Modules/Report1.bas index f882996..fdd5ef3 100644 --- a/VBA/VBA-Code_By_Modules/Report1.bas +++ b/VBA/VBA-Code_By_Modules/Report1.bas @@ -41,6 +41,17 @@ Sub GenerateMorningShiftAnalysis() Exit Sub End If + ' Add big title at row 1 + With wsAnalysis.Range("A1:E1") + .Merge + .Value = "Analysis Report" + .Interior.Color = RGB(255, 199, 206) ' Light red + .Font.Size = 16 + .Font.Bold = True + .HorizontalAlignment = xlCenter + .VerticalAlignment = xlCenter + End With + Set wsRosterCopy = Sheets(latestRosterName) Set wsPersonnel = Sheets("Morning PersonnelList") @@ -57,7 +68,7 @@ Sub GenerateMorningShiftAnalysis() wsAnalysis.Range("A1").Value = "Morning Slot Analysis" wsAnalysis.Range("A1").Font.Bold = True wsAnalysis.Range("A1").Font.Size = 14 - tableStartRow = 3 ' header starts here + tableStartRow = 4 ' header starts here ' Header row With wsAnalysis @@ -118,14 +129,32 @@ Sub GenerateMorningShiftAnalysis() If dict.exists(empName) Then wsAnalysis.Cells(i, 3).Value = dict(empName) wsAnalysis.Cells(i, 4).FormulaR1C1 = "=RC[-1]-RC[-2]" - wsAnalysis.Cells(i, 5).FormulaR1C1 = "=IF(RC[-3]=0,"""",RC[-1]/RC[-3]*100)" + wsAnalysis.Cells(i, 5).FormulaR1C1 = "=IF(RC[-3]=0,0,RC[-1]/RC[-3]*100)" End If Next i ' Format as Table Dim tableRange As Range - Set tableRange = wsAnalysis.Range("A" & tableStartRow & ":E" & wsAnalysis.Cells(wsAnalysis.Rows.Count, 1).End(xlUp).row) - wsAnalysis.ListObjects.Add(xlSrcRange, tableRange, , xlYes).Name = "MorningShiftTable" + Dim analysisTable As ListObject + + lastRow = wsAnalysis.Cells(wsAnalysis.Rows.Count, 1).End(xlUp).row + Set tableRange = wsAnalysis.Range("A" & tableStartRow & ":E" & lastRow) + Set analysisTable = wsAnalysis.ListObjects.Add(xlSrcRange, tableRange, , xlYes) + analysisTable.Name = "MorningShiftTable" + + ' Format % column to 2 decimal places + analysisTable.ListColumns("% Difference").DataBodyRange.NumberFormat = "0.00" + + + ' Add small section title at row 3 + With wsAnalysis.Range("A3:C3") + .Merge + .Value = "Morning Slot Analysis" + .Font.Bold = True + .HorizontalAlignment = xlCenter + .VerticalAlignment = xlCenter + .Interior.Color = analysisTable.HeaderRowRange.Interior.Color + End With MsgBox "Morning shift analysis generated using '" & latestRosterName & "'.", vbInformation End Sub From 27cc2cb657cc1cf016a03e80de5b1d10b93675c4 Mon Sep 17 00:00:00 2001 From: Casielim Date: Wed, 23 Jul 2025 22:48:11 +0800 Subject: [PATCH 09/12] Generate analysis report --- .../GenerateAnalysisReport.bas | 154 ++++++++++++++++++ 1 file changed, 154 insertions(+) create mode 100644 VBA/VBA-Code_By_Modules/GenerateAnalysisReport.bas diff --git a/VBA/VBA-Code_By_Modules/GenerateAnalysisReport.bas b/VBA/VBA-Code_By_Modules/GenerateAnalysisReport.bas new file mode 100644 index 0000000..bb773ad --- /dev/null +++ b/VBA/VBA-Code_By_Modules/GenerateAnalysisReport.bas @@ -0,0 +1,154 @@ +Attribute VB_Name = "GenerateAnalysisReport" +' Reusable function to generate side-by-side shift analysis blocks +Sub GenerateShiftAnalysisBlock(wsAnalysis As Worksheet, rosterSheet As Worksheet, _ + personnelSheetName As String, tableName As String, _ + slotTitle As String, rosterCol As Long, startCol As Long) + + Dim wsPersonnel As Worksheet + Dim tbl As ListObject + Dim nameList As Range, dutyCounterList As Range + Dim dict As Object + Dim empName As String + Dim cell As Range, cellValue As String, currStaff As String + Dim rowOffset As Long: rowOffset = 4 + Dim lastRow As Long, nextRow As Long + Dim tableRange As Range, analysisTable As ListObject + Dim i As Long, tableWidth As Long: tableWidth = 5 + + Set wsPersonnel = Sheets(personnelSheetName) + Set tbl = wsPersonnel.ListObjects(tableName) + Set nameList = tbl.ListColumns("Name").DataBodyRange + Set dutyCounterList = tbl.ListColumns("Duties Counter").DataBodyRange + + ' Add small section title + With wsAnalysis.Cells(3, startCol).Resize(1, 3) + .Merge + .Value = slotTitle + .Font.Bold = True + .HorizontalAlignment = xlCenter + .Interior.Color = RGB(184, 204, 228) + End With + + ' Add header + With wsAnalysis + .Cells(rowOffset, startCol).Value = "Name" + .Cells(rowOffset, startCol + 1).Value = "System Counter" + .Cells(rowOffset, startCol + 2).Value = "Actual Counter" + .Cells(rowOffset, startCol + 3).Value = "Difference" + .Cells(rowOffset, startCol + 4).Value = "% Difference" + End With + + Set dict = CreateObject("Scripting.Dictionary") + For i = 1 To nameList.Rows.Count + empName = UCase(Trim(nameList.Cells(i, 1).Value)) + wsAnalysis.Cells(rowOffset + i, startCol).Value = empName + wsAnalysis.Cells(rowOffset + i, startCol + 1).Value = dutyCounterList.Cells(i, 1).Value + dict(empName) = 0 + Next i + + For i = 6 To 186 + Set cell = rosterSheet.Cells(i, rosterCol) + cellValue = cell.Value + + If InStr(cellValue, vbNewLine) > 0 Then + currStaff = UCase(Trim(Replace(Split(cellValue, vbNewLine)(0), Chr(160), " "))) + Else + currStaff = UCase(Trim(cellValue)) + End If + + If Len(currStaff) > 0 And currStaff <> "CLOSED" Then + If dict.exists(currStaff) Then + dict(currStaff) = dict(currStaff) + 1 + Else + nextRow = wsAnalysis.Cells(wsAnalysis.Rows.Count, startCol).End(xlUp).row + 1 + wsAnalysis.Cells(nextRow, startCol).Value = currStaff + wsAnalysis.Cells(nextRow, startCol + 1).Value = 0 + wsAnalysis.Cells(nextRow, startCol + 2).Value = 1 + wsAnalysis.Cells(nextRow, startCol + 3).FormulaR1C1 = "=RC[-1]-RC[-2]" + wsAnalysis.Cells(nextRow, startCol + 4).FormulaR1C1 = "=IF(RC[-3]=0,"""",RC[-1]/RC[-3]*100)" + dict(currStaff) = 1 + wsAnalysis.Range(wsAnalysis.Cells(nextRow, startCol), wsAnalysis.Cells(nextRow, startCol + 4)).Interior.Color = RGB(255, 255, 153) + End If + End If + Next i + + For i = rowOffset + 1 To wsAnalysis.Cells(wsAnalysis.Rows.Count, startCol).End(xlUp).row + empName = UCase(Trim(wsAnalysis.Cells(i, startCol).Value)) + If dict.exists(empName) Then + wsAnalysis.Cells(i, startCol + 2).Value = dict(empName) + wsAnalysis.Cells(i, startCol + 3).FormulaR1C1 = "=RC[-1]-RC[-2]" + wsAnalysis.Cells(i, startCol + 4).FormulaR1C1 = "=IF(RC[-3]=0,0,RC[-1]/RC[-3]*100)" + End If + Next i + + ' Format as Table + lastRow = wsAnalysis.Cells(wsAnalysis.Rows.Count, startCol).End(xlUp).row + Set tableRange = wsAnalysis.Range(wsAnalysis.Cells(rowOffset, startCol), wsAnalysis.Cells(lastRow, startCol + tableWidth - 1)) + Set analysisTable = wsAnalysis.ListObjects.Add(xlSrcRange, tableRange, , xlYes) + analysisTable.Name = Replace(slotTitle, " ", "") & "Table" + analysisTable.ListColumns("% Difference").DataBodyRange.NumberFormat = "0.00" +End Sub + +' Master sub to create the whole Analysis Report layout +Sub MasterGenerateAllAnalyses() + Dim wsAnalysis As Worksheet + Dim rosterSheet As Worksheet + Dim latestRosterName As String + Dim newestDate As Date + Dim sht As Worksheet + + newestDate = 0 + For Each sht In ThisWorkbook.Sheets + If sht.Name Like "ActualRoster_*" Then + Dim dtPart As String + dtPart = Replace(Mid(sht.Name, 14), "_", " ") + On Error Resume Next + Dim parsedDate As Date + parsedDate = CDate(Left(dtPart, 4) & "/" & Mid(dtPart, 5, 2) & "/" & Mid(dtPart, 7, 2) & " " & Mid(dtPart, 10, 2) & ":" & Mid(dtPart, 12, 2)) + If Err.Number = 0 Then + If parsedDate > newestDate Then + newestDate = parsedDate + latestRosterName = sht.Name + End If + End If + On Error GoTo 0 + End If + Next sht + + If latestRosterName = "" Then + MsgBox "No ActualRoster_* sheet found.", vbExclamation + Exit Sub + End If + + Set rosterSheet = Sheets(latestRosterName) + + ' Create clean MorningAnalysis sheet + On Error Resume Next + Application.DisplayAlerts = False + Sheets("MorningAnalysis").Delete + Application.DisplayAlerts = True + On Error GoTo 0 + Set wsAnalysis = Sheets.Add(After:=Sheets(Sheets.Count)) + wsAnalysis.Name = "AnalysisReport" + + ' Big title + With wsAnalysis.Range("A1:Z1") + .Merge + .Value = "Analysis Report" + .Font.Size = 16 + .Font.Bold = True + .Interior.Color = RGB(255, 199, 206) + .HorizontalAlignment = xlCenter + End With + + ' Generate all 5 analyses side by side + GenerateShiftAnalysisBlock wsAnalysis, rosterSheet, "Loan Mail Box PersonnelList", "LoanMailBoxMainList", "Loan Mail Box Slot Analysis", LMB_COL, 1 + GenerateShiftAnalysisBlock wsAnalysis, rosterSheet, "Morning PersonnelList", "MorningMainList", "Morning Slot Analysis", MOR_COL, 7 + GenerateShiftAnalysisBlock wsAnalysis, rosterSheet, "Afternoon PersonnelList", "AfternoonMainList", "Afternoon Slot Analysis", AFT_COL, 13 + GenerateShiftAnalysisBlock wsAnalysis, rosterSheet, "AOH PersonnelList", "AOHMainList", "AOH Slot Analysis", AOH_COL, 19 + GenerateShiftAnalysisBlock wsAnalysis, rosterSheet, "Sat AOH PersonnelList", "SatAOHMainList", "Sat AOH Slot Analysis", SAT_AOH_COL1, 25 + + MsgBox "All shift analyses completed successfully!" +End Sub + + From 7d5c1f99e612584ab67eff45316e25b554dff989 Mon Sep 17 00:00:00 2001 From: Casielim Date: Thu, 31 Jul 2025 22:16:05 +0800 Subject: [PATCH 10/12] Add protection to analysis --- .../GenerateAnalysisReport.bas | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/VBA/VBA-Code_By_Modules/GenerateAnalysisReport.bas b/VBA/VBA-Code_By_Modules/GenerateAnalysisReport.bas index bb773ad..0983807 100644 --- a/VBA/VBA-Code_By_Modules/GenerateAnalysisReport.bas +++ b/VBA/VBA-Code_By_Modules/GenerateAnalysisReport.bas @@ -147,6 +147,24 @@ Sub MasterGenerateAllAnalyses() GenerateShiftAnalysisBlock wsAnalysis, rosterSheet, "Afternoon PersonnelList", "AfternoonMainList", "Afternoon Slot Analysis", AFT_COL, 13 GenerateShiftAnalysisBlock wsAnalysis, rosterSheet, "AOH PersonnelList", "AOHMainList", "AOH Slot Analysis", AOH_COL, 19 GenerateShiftAnalysisBlock wsAnalysis, rosterSheet, "Sat AOH PersonnelList", "SatAOHMainList", "Sat AOH Slot Analysis", SAT_AOH_COL1, 25 + GenerateShiftAnalysisBlock wsAnalysis, rosterSheet, "Sat AOH PersonnelList", "SatAOHMainList", _ + "Sat AOH Slot Analysis", SAT_AOH_COL1, 25, SAT_AOH_COL2 + GenerateTotalSummaryTable wsAnalysis + + With wsAnalysis.Cells + .Locked = True + End With + + wsAnalysis.Protect password:="nuslib2017@52", _ + AllowSorting:=True, _ + AllowFiltering:=True, _ + AllowFormattingCells:=True + + + + MsgBox "All shift analyses completed for '" & rosterSheet.Name & "'!", vbInformation +End Sub + MsgBox "All shift analyses completed successfully!" End Sub From 508ecfc1ed9386fa70997eac22ed313f5b617207 Mon Sep 17 00:00:00 2001 From: Casielim Date: Thu, 31 Jul 2025 22:18:14 +0800 Subject: [PATCH 11/12] Enable user to choose sheet he wants to do analysis --- .../GenerateAnalysisReport.bas | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/VBA/VBA-Code_By_Modules/GenerateAnalysisReport.bas b/VBA/VBA-Code_By_Modules/GenerateAnalysisReport.bas index 0983807..87021a1 100644 --- a/VBA/VBA-Code_By_Modules/GenerateAnalysisReport.bas +++ b/VBA/VBA-Code_By_Modules/GenerateAnalysisReport.bas @@ -121,6 +121,24 @@ Sub MasterGenerateAllAnalyses() End If Set rosterSheet = Sheets(latestRosterName) + ' Prompt user to click on any cell in the target ActualRoster_* sheet + On Error Resume Next + Set userRange = Application.InputBox( _ + Prompt:="Please choose one 'ActualRoster' sheet to analyse." & vbCrLf & _ + "After that, click on any cell on the selected 'ActualRoster' sheet." & vbCrLf & _ + "The sheet name must start with 'ActualRoster_'", _ + title:="Select Actual Roster Sheet", _ + Type:=8) + On Error GoTo 0 + + If userRange Is Nothing Then Exit Sub ' User cancelled + + Set selectedSheet = userRange.Worksheet + If selectedSheet.Name Like "ActualRoster_*" = False Then + MsgBox "Invalid selection. Please choose a sheet that starts with 'ActualRoster_'.", vbExclamation + Exit Sub + End If + Set rosterSheet = selectedSheet ' Create clean MorningAnalysis sheet On Error Resume Next From c129b14ffd8cabde9d80355fa9ebc5e6bc9aa148 Mon Sep 17 00:00:00 2001 From: Casielim Date: Thu, 31 Jul 2025 22:21:44 +0800 Subject: [PATCH 12/12] Format analysis report --- .../GenerateAnalysisReport.bas | 272 ++++++++++++++---- 1 file changed, 209 insertions(+), 63 deletions(-) diff --git a/VBA/VBA-Code_By_Modules/GenerateAnalysisReport.bas b/VBA/VBA-Code_By_Modules/GenerateAnalysisReport.bas index 87021a1..8ebc6e6 100644 --- a/VBA/VBA-Code_By_Modules/GenerateAnalysisReport.bas +++ b/VBA/VBA-Code_By_Modules/GenerateAnalysisReport.bas @@ -1,8 +1,10 @@ Attribute VB_Name = "GenerateAnalysisReport" +Private last_row_roster As Long ' Reusable function to generate side-by-side shift analysis blocks Sub GenerateShiftAnalysisBlock(wsAnalysis As Worksheet, rosterSheet As Worksheet, _ personnelSheetName As String, tableName As String, _ - slotTitle As String, rosterCol As Long, startCol As Long) + slotTitle As String, rosterCol1 As Long, startCol As Long, _ + Optional rosterCol2 As Variant) Dim wsPersonnel As Worksheet Dim tbl As ListObject @@ -11,9 +13,10 @@ Sub GenerateShiftAnalysisBlock(wsAnalysis As Worksheet, rosterSheet As Worksheet Dim empName As String Dim cell As Range, cellValue As String, currStaff As String Dim rowOffset As Long: rowOffset = 4 - Dim lastRow As Long, nextRow As Long + Dim lastRow As Long, NextRow As Long Dim tableRange As Range, analysisTable As ListObject Dim i As Long, tableWidth As Long: tableWidth = 5 + Dim enteredPassword As String Set wsPersonnel = Sheets(personnelSheetName) Set tbl = wsPersonnel.ListObjects(tableName) @@ -38,43 +41,73 @@ Sub GenerateShiftAnalysisBlock(wsAnalysis As Worksheet, rosterSheet As Worksheet .Cells(rowOffset, startCol + 4).Value = "% Difference" End With + ' Check if table exists and if it is empty + On Error Resume Next + Set tbl = wsPersonnel.ListObjects(tableName) + On Error GoTo 0 + + If tbl Is Nothing Or tbl.ListRows.count = 0 Then + ' Create an empty analysis table with only headers + Set tableRange = wsAnalysis.Range(wsAnalysis.Cells(rowOffset, startCol), _ + wsAnalysis.Cells(rowOffset, startCol + tableWidth - 1)) + + Set analysisTable = wsAnalysis.ListObjects.Add(xlSrcRange, tableRange, , xlYes) + analysisTable.Name = Replace(slotTitle, " ", "") & "Table" + + ' No data rows, so skip formatting % Difference + Exit Sub + End If + + Set dict = CreateObject("Scripting.Dictionary") - For i = 1 To nameList.Rows.Count + ' Load initial staff counters + For i = 1 To nameList.Rows.count empName = UCase(Trim(nameList.Cells(i, 1).Value)) wsAnalysis.Cells(rowOffset + i, startCol).Value = empName wsAnalysis.Cells(rowOffset + i, startCol + 1).Value = dutyCounterList.Cells(i, 1).Value dict(empName) = 0 Next i - For i = 6 To 186 - Set cell = rosterSheet.Cells(i, rosterCol) - cellValue = cell.Value - - If InStr(cellValue, vbNewLine) > 0 Then - currStaff = UCase(Trim(Replace(Split(cellValue, vbNewLine)(0), Chr(160), " "))) - Else - currStaff = UCase(Trim(cellValue)) - End If - - If Len(currStaff) > 0 And currStaff <> "CLOSED" Then - If dict.exists(currStaff) Then - dict(currStaff) = dict(currStaff) + 1 + Dim colIndex As Variant + Dim colList As Variant + + If IsMissing(rosterCol2) Then + colList = Array(rosterCol1) + Else + colList = Array(rosterCol1, rosterCol2) + End If + + For Each colIndex In colList + For i = 6 To last_row_roster + Set cell = rosterSheet.Cells(i, colIndex) + cellValue = cell.Value + + If InStr(cellValue, vbNewLine) > 0 Then + currStaff = UCase(Trim(Replace(Split(cellValue, vbNewLine)(0), Chr(160), " "))) Else - nextRow = wsAnalysis.Cells(wsAnalysis.Rows.Count, startCol).End(xlUp).row + 1 - wsAnalysis.Cells(nextRow, startCol).Value = currStaff - wsAnalysis.Cells(nextRow, startCol + 1).Value = 0 - wsAnalysis.Cells(nextRow, startCol + 2).Value = 1 - wsAnalysis.Cells(nextRow, startCol + 3).FormulaR1C1 = "=RC[-1]-RC[-2]" - wsAnalysis.Cells(nextRow, startCol + 4).FormulaR1C1 = "=IF(RC[-3]=0,"""",RC[-1]/RC[-3]*100)" - dict(currStaff) = 1 - wsAnalysis.Range(wsAnalysis.Cells(nextRow, startCol), wsAnalysis.Cells(nextRow, startCol + 4)).Interior.Color = RGB(255, 255, 153) + currStaff = UCase(Trim(cellValue)) End If - End If - Next i + + If Len(currStaff) > 0 And currStaff <> "CLOSED" Then + If dict.Exists(currStaff) Then + dict(currStaff) = dict(currStaff) + 1 + Else + NextRow = wsAnalysis.Cells(wsAnalysis.Rows.count, startCol).End(xlUp).row + 1 + wsAnalysis.Cells(NextRow, startCol).Value = currStaff + wsAnalysis.Cells(NextRow, startCol + 1).Value = 0 + wsAnalysis.Cells(NextRow, startCol + 2).Value = 1 + wsAnalysis.Cells(NextRow, startCol + 3).FormulaR1C1 = "=RC[-1]-RC[-2]" + wsAnalysis.Cells(NextRow, startCol + 4).FormulaR1C1 = "=IF(RC[-3]=0,"""",RC[-1]/RC[-3]*100)" + dict(currStaff) = 1 + wsAnalysis.Range(wsAnalysis.Cells(NextRow, startCol), wsAnalysis.Cells(NextRow, startCol + 4)).Interior.Color = RGB(255, 255, 153) + End If + End If + Next i + Next colIndex - For i = rowOffset + 1 To wsAnalysis.Cells(wsAnalysis.Rows.Count, startCol).End(xlUp).row + For i = rowOffset + 1 To wsAnalysis.Cells(wsAnalysis.Rows.count, startCol).End(xlUp).row empName = UCase(Trim(wsAnalysis.Cells(i, startCol).Value)) - If dict.exists(empName) Then + If dict.Exists(empName) Then wsAnalysis.Cells(i, startCol + 2).Value = dict(empName) wsAnalysis.Cells(i, startCol + 3).FormulaR1C1 = "=RC[-1]-RC[-2]" wsAnalysis.Cells(i, startCol + 4).FormulaR1C1 = "=IF(RC[-3]=0,0,RC[-1]/RC[-3]*100)" @@ -82,45 +115,136 @@ Sub GenerateShiftAnalysisBlock(wsAnalysis As Worksheet, rosterSheet As Worksheet Next i ' Format as Table - lastRow = wsAnalysis.Cells(wsAnalysis.Rows.Count, startCol).End(xlUp).row + lastRow = wsAnalysis.Cells(wsAnalysis.Rows.count, startCol).End(xlUp).row Set tableRange = wsAnalysis.Range(wsAnalysis.Cells(rowOffset, startCol), wsAnalysis.Cells(lastRow, startCol + tableWidth - 1)) Set analysisTable = wsAnalysis.ListObjects.Add(xlSrcRange, tableRange, , xlYes) analysisTable.Name = Replace(slotTitle, " ", "") & "Table" analysisTable.ListColumns("% Difference").DataBodyRange.NumberFormat = "0.00" End Sub +Sub GenerateTotalSummaryTable(wsAnalysis As Worksheet) + Dim summaryDict As Object + Set summaryDict = CreateObject("Scripting.Dictionary") + + Dim tableNames As Variant + tableNames = Array("LoanMailBoxSlotAnalysisTable", "MorningSlotAnalysisTable", _ + "AfternoonSlotAnalysisTable", "AOHSlotAnalysisTable", "SatAOHSlotAnalysisTable") -' Master sub to create the whole Analysis Report layout -Sub MasterGenerateAllAnalyses() - Dim wsAnalysis As Worksheet - Dim rosterSheet As Worksheet - Dim latestRosterName As String - Dim newestDate As Date - Dim sht As Worksheet - - newestDate = 0 - For Each sht In ThisWorkbook.Sheets - If sht.Name Like "ActualRoster_*" Then - Dim dtPart As String - dtPart = Replace(Mid(sht.Name, 14), "_", " ") - On Error Resume Next - Dim parsedDate As Date - parsedDate = CDate(Left(dtPart, 4) & "/" & Mid(dtPart, 5, 2) & "/" & Mid(dtPart, 7, 2) & " " & Mid(dtPart, 10, 2) & ":" & Mid(dtPart, 12, 2)) - If Err.Number = 0 Then - If parsedDate > newestDate Then - newestDate = parsedDate - latestRosterName = sht.Name - End If + Dim tbl As ListObject, row As ListRow + Dim empName As String + Dim sysCount As Long, actCount As Long + Dim tblName As Variant + + ' Loop through each analysis table + For Each tblName In tableNames + On Error Resume Next + Set tbl = wsAnalysis.ListObjects(tblName) + On Error GoTo 0 + + ' Skip if table doesn't exist or is empty + If Not tbl Is Nothing Then + If tbl.ListRows.count > 0 Then + ' Loop through each row in the table + For Each row In tbl.ListRows + empName = UCase(Trim(row.Range.Cells(1, 1).Value)) + sysCount = Val(row.Range.Cells(1, 2).Value) + actCount = Val(row.Range.Cells(1, 3).Value) + + If summaryDict.Exists(empName) Then + Dim counts As Variant + counts = summaryDict(empName) + counts(0) = counts(0) + sysCount + counts(1) = counts(1) + actCount + summaryDict(empName) = counts + Else + summaryDict(empName) = Array(sysCount, actCount) + End If + Next row End If - On Error GoTo 0 End If - Next sht + Set tbl = Nothing + Next tblName + + ' Determine where to place the summary table + Dim startCol As Long + startCol = wsAnalysis.Cells(4, wsAnalysis.Columns.count).End(xlToLeft).Column + 2 + Dim rowOffset As Long: rowOffset = 4 + + ' Add table header + With wsAnalysis + .Cells(3, startCol).Resize(1, 5).Merge + .Cells(3, startCol).Value = "Total Summary" + .Cells(3, startCol).Font.Bold = True + .Cells(3, startCol).Interior.Color = RGB(184, 204, 228) + .Cells(3, startCol).HorizontalAlignment = xlCenter - If latestRosterName = "" Then - MsgBox "No ActualRoster_* sheet found.", vbExclamation + .Cells(rowOffset, startCol).Value = "Name" + .Cells(rowOffset, startCol + 1).Value = "System Counter" + .Cells(rowOffset, startCol + 2).Value = "Actual Counter" + .Cells(rowOffset, startCol + 3).Value = "Difference" + .Cells(rowOffset, startCol + 4).Value = "% Difference" + .Range(.Cells(rowOffset, startCol), .Cells(rowOffset, startCol + 4)).Font.Bold = True + End With + + ' Write data into sheet + Dim i As Long: i = rowOffset + 1 + Dim diff As Long, pctDiff As Double + Dim sysVal As Long, actVal As Long + Dim staff As Variant + + For Each staff In summaryDict.Keys + sysVal = summaryDict(staff)(0) + actVal = summaryDict(staff)(1) + diff = actVal - sysVal + + If sysVal <> 0 Then + pctDiff = diff / sysVal * 100 + Else + pctDiff = 0 + End If + + wsAnalysis.Cells(i, startCol).Value = staff + wsAnalysis.Cells(i, startCol + 1).Value = sysVal + wsAnalysis.Cells(i, startCol + 2).Value = actVal + wsAnalysis.Cells(i, startCol + 3).Value = diff + wsAnalysis.Cells(i, startCol + 4).Value = pctDiff + i = i + 1 + Next staff + + ' Create an empty table if no data exists + Dim lastRow As Long + If summaryDict.count = 0 Then + lastRow = rowOffset + Else + lastRow = wsAnalysis.Cells(wsAnalysis.Rows.count, startCol).End(xlUp).row + End If + + ' Format as table + Dim tableRange As Range + Set tableRange = wsAnalysis.Range(wsAnalysis.Cells(rowOffset, startCol), wsAnalysis.Cells(lastRow, startCol + 4)) + + Dim summaryTable As ListObject + Set summaryTable = wsAnalysis.ListObjects.Add(xlSrcRange, tableRange, , xlYes) + summaryTable.Name = "TotalSummaryTable" + If summaryTable.ListRows.count > 0 Then + summaryTable.ListColumns("% Difference").DataBodyRange.NumberFormat = "0.00" + End If +End Sub + + + +Sub MasterGenerateAllAnalyses() + Dim wsAnalysis As Worksheet + Dim rosterSheet As Worksheet + Dim userRange As Range + Dim selectedSheet As Worksheet + Const password As String = "rostering2025" + + enteredPassword = InputBox("Please enter the password to generate analysis report:", "Password Authentication") + If enteredPassword <> password Then + MsgBox "Incorrect password. Unable to generate report.", vbCritical Exit Sub End If - Set rosterSheet = Sheets(latestRosterName) ' Prompt user to click on any cell in the target ActualRoster_* sheet On Error Resume Next Set userRange = Application.InputBox( _ @@ -140,15 +264,29 @@ Sub MasterGenerateAllAnalyses() End If Set rosterSheet = selectedSheet - ' Create clean MorningAnalysis sheet + ' Create ReportAnalysis sheet + Dim dtNamePart As String, formattedName As String + dtNamePart = Mid(selectedSheet.Name, 14) + formattedName = "AnalysisReport_" & dtNamePart + + Set wsAnalysis = Sheets.Add(After:=Sheets(Sheets.count)) On Error Resume Next - Application.DisplayAlerts = False - Sheets("MorningAnalysis").Delete - Application.DisplayAlerts = True + wsAnalysis.Name = formattedName + If Err.Number <> 0 Then + MsgBox "Could not name sheet as " & formattedName & ". It may already exist.", vbExclamation + wsAnalysis.Name = "AnalysisReport_" & Format(Now, "yyyymmdd_hhnnss") + End If On Error GoTo 0 - Set wsAnalysis = Sheets.Add(After:=Sheets(Sheets.Count)) - wsAnalysis.Name = "AnalysisReport" + 'Find last row of roster + If selectedSheet.Cells(2, 10).Value = "Jan-Jun" And selectedSheet.Cells(2, 13).Value Mod 4 = 0 Then + last_row_roster = 187 + ElseIf selectedSheet.Cells(2, 10).Value = "Jan-Jun" Then + last_row_roster = 186 + Else + last_row_roster = 189 + End If + ' Big title With wsAnalysis.Range("A1:Z1") .Merge @@ -159,12 +297,19 @@ Sub MasterGenerateAllAnalyses() .HorizontalAlignment = xlCenter End With + ' Show selected ActualRoster sheet name in row 2 + With wsAnalysis.Range("A2:Z2") + .Merge + .Value = "Based on: " & rosterSheet.Name + .Font.Italic = True + .HorizontalAlignment = xlCenter + End With + ' Generate all 5 analyses side by side GenerateShiftAnalysisBlock wsAnalysis, rosterSheet, "Loan Mail Box PersonnelList", "LoanMailBoxMainList", "Loan Mail Box Slot Analysis", LMB_COL, 1 GenerateShiftAnalysisBlock wsAnalysis, rosterSheet, "Morning PersonnelList", "MorningMainList", "Morning Slot Analysis", MOR_COL, 7 GenerateShiftAnalysisBlock wsAnalysis, rosterSheet, "Afternoon PersonnelList", "AfternoonMainList", "Afternoon Slot Analysis", AFT_COL, 13 GenerateShiftAnalysisBlock wsAnalysis, rosterSheet, "AOH PersonnelList", "AOHMainList", "AOH Slot Analysis", AOH_COL, 19 - GenerateShiftAnalysisBlock wsAnalysis, rosterSheet, "Sat AOH PersonnelList", "SatAOHMainList", "Sat AOH Slot Analysis", SAT_AOH_COL1, 25 GenerateShiftAnalysisBlock wsAnalysis, rosterSheet, "Sat AOH PersonnelList", "SatAOHMainList", _ "Sat AOH Slot Analysis", SAT_AOH_COL1, 25, SAT_AOH_COL2 GenerateTotalSummaryTable wsAnalysis @@ -184,7 +329,8 @@ Sub MasterGenerateAllAnalyses() End Sub - MsgBox "All shift analyses completed successfully!" +Sub TestGenerateSummary() + Call GenerateTotalSummaryTable(Sheets("AnalysisReport_20250724_0306")) End Sub