From b2e084bd10169da82e74c966a9b55bf272101e16 Mon Sep 17 00:00:00 2001 From: kevinowino869 Date: Sun, 2 Mar 2025 14:21:48 +0100 Subject: [PATCH 1/5] Update ClearReports/ClearReports.bas --- ClearReports/ClearReports.bas | 72 +++++++++++++++++------------------ 1 file changed, 35 insertions(+), 37 deletions(-) diff --git a/ClearReports/ClearReports.bas b/ClearReports/ClearReports.bas index 5fd635c..34821cc 100644 --- a/ClearReports/ClearReports.bas +++ b/ClearReports/ClearReports.bas @@ -1,37 +1,35 @@ -Attribute VB_Name = "ClearReports" -Sub ClearReportsButton() - Dim ws As Worksheet - Dim wsArr As Variant - Dim i As Integer - - ' Define sheets to keep - wsArr = Array("Dashboard", "Datasheet", "Code") - - Application.ScreenUpdating = False - Application.DisplayAlerts = False - - ' Loop backwards to avoid deletion issues - For i = ThisWorkbook.Sheets.Count To 1 Step -1 - Set ws = ThisWorkbook.Sheets(i) - If Not IsInArray(ws.Name, wsArr) Then - ws.Delete - End If - Next i - - Application.DisplayAlerts = True - Application.ScreenUpdating = True - MsgBox "All county reports have been cleared!", vbInformation -End Sub - -' Function to check if sheet name is in the list of sheets to keep -Function IsInArray(val As String, arr As Variant) As Boolean - Dim i As Integer - For i = LBound(arr) To UBound(arr) - If arr(i) = val Then - IsInArray = True - Exit Function - End If - Next i - IsInArray = False -End Function - +Sub ClearReportsButton() + Dim ws As Worksheet + Dim wsArr As Variant + Dim i As Integer + + ' Define sheets to keep + wsArr = Array("Dashboard", "Datasheet", "Code") + + Application.ScreenUpdating = False + Application.DisplayAlerts = False + + ' Loop backwards to avoid deletion issues + For i = ThisWorkbook.Sheets.Count To 1 Step -1 + Set ws = ThisWorkbook.Sheets(i) + If Not IsInArray(ws.Name, wsArr) Then + ws.Delete + End If + Next i + + Application.DisplayAlerts = True + Application.ScreenUpdating = True + MsgBox "All county reports have been cleared!", vbInformation +End Sub + +' Function to check if sheet name is in the list of sheets to keep +Function IsInArray(val As String, arr As Variant) As Boolean + Dim i As Integer + For i = LBound(arr) To UBound(arr) + If arr(i) = val Then + IsInArray = True + Exit Function + End If + Next i + IsInArray = False +End Function From c7080f0a2fe571d10b71a38bbbdfb3ea7880a39f Mon Sep 17 00:00:00 2001 From: kevinowino869 Date: Sun, 2 Mar 2025 14:22:49 +0100 Subject: [PATCH 2/5] Update DetailedReport/DetailedReport.bas --- DetailedReport/DetailedReport.bas | 157 +++++++++++++++--------------- 1 file changed, 78 insertions(+), 79 deletions(-) diff --git a/DetailedReport/DetailedReport.bas b/DetailedReport/DetailedReport.bas index 98acfa7..90c3872 100644 --- a/DetailedReport/DetailedReport.bas +++ b/DetailedReport/DetailedReport.bas @@ -1,79 +1,78 @@ -Attribute VB_Name = "DetailedReport" -Sub GenerateColumnReports() - Dim ws As Worksheet, wsNew As Worksheet - Dim lastRow As Long, columnCol As Long, headerRow As Long - Dim cell As Range, colValue As Variant - Dim dict As Object - Dim rng As Range, copyRange As Range - Dim colName As String - - ' Set worksheet and find last row - Set ws = ThisWorkbook.Sheets("Datasheet") ' Change to your sheet name - lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row - columnCol = 3 ' Adjust this to the column number you want to group by - headerRow = 1 ' Adjust if headers are located on a different row - - ' Create dictionary to store unique values - Set dict = CreateObject("Scripting.Dictionary") - - ' Loop through column to find unique values - For Each cell In ws.Range(ws.Cells(headerRow + 1, columnCol), ws.Cells(lastRow, columnCol)) - colValue = Trim(cell.Value) - If colValue <> "" And Not dict.exists(colValue) Then - dict.Add colValue, Nothing - End If - Next cell - - ' Create sheets for each unique value and copy relevant data - Application.ScreenUpdating = False - For Each colValue In dict.keys - ' Generate a valid sheet name - colName = colValue - colName = Replace(colName, "/", "_") - colName = Replace(colName, "\", "_") - colName = Replace(colName, "?", "_") - colName = Replace(colName, "*", "_") - colName = Replace(colName, "[", "_") - colName = Replace(colName, "]", "_") - colName = Replace(colName, ":", "_") - colName = Left(colName, 31) ' Ensure sheet name is max 31 characters - - ' Check if sheet exists - On Error Resume Next - Set wsNew = ThisWorkbook.Sheets(colName) - On Error GoTo 0 - - ' If sheet doesn't exist, create it - If wsNew Is Nothing Then - Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) - wsNew.Name = colName - End If - - ' Clear previous content except headers - wsNew.Cells.Clear - ws.Rows(headerRow).Copy wsNew.Rows(headerRow) - - ' Apply filter and copy relevant rows - ws.Range(ws.Cells(headerRow + 1, 1), ws.Cells(lastRow, ws.UsedRange.Columns.Count)).AutoFilter Field:=columnCol, Criteria1:=colValue - - ' Ensure there's data before copying - On Error Resume Next - Set rng = ws.Rows(headerRow + 1 & ":" & lastRow).SpecialCells(xlCellTypeVisible) - On Error GoTo 0 - - - - ' Turn off AutoFilter - ws.AutoFilterMode = False - - ' Adjust column width for better visibility - wsNew.Cells.EntireColumn.AutoFit - - ' Reset worksheet variable - Set wsNew = Nothing - Next colValue - Application.ScreenUpdating = True - - MsgBox "Column reports generated successfully!", vbInformation -End Sub - +Sub GenerateColumnReports() + Dim ws As Worksheet, wsNew As Worksheet + Dim lastRow As Long, columnCol As Long, headerRow As Long + Dim cell As Range, colValue As Variant + Dim dict As Object + Dim rng As Range, copyRange As Range + Dim colName As String + + ' Set worksheet and find last row + Set ws = ThisWorkbook.Sheets("Datasheet") ' Change to your sheet name + lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + columnCol = 3 ' Adjust this to the column number you want to group by + headerRow = 1 ' Adjust if headers are located on a different row + + ' Create dictionary to store unique values + Set dict = CreateObject("Scripting.Dictionary") + + ' Loop through column to find unique values + For Each cell In ws.Range(ws.Cells(headerRow + 1, columnCol), ws.Cells(lastRow, columnCol)) + colValue = Trim(cell.Value) + If colValue <> "" And Not dict.exists(colValue) Then + dict.Add colValue, Nothing + End If + Next cell + + ' Create sheets for each unique value and copy relevant data + Application.ScreenUpdating = False + For Each colValue In dict.keys + ' Generate a valid sheet name + colName = colValue + colName = Replace(colName, "/", "_") + colName = Replace(colName, "\", "_") + colName = Replace(colName, "?", "_") + colName = Replace(colName, "*", "_") + colName = Replace(colName, "[", "_") + colName = Replace(colName, "]", "_") + colName = Replace(colName, ":", "_") + colName = Left(colName, 31) ' Ensure sheet name is max 31 characters + + ' Check if sheet exists + On Error Resume Next + Set wsNew = ThisWorkbook.Sheets(colName) + On Error GoTo 0 + + ' If sheet doesn't exist, create it + If wsNew Is Nothing Then + Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) + wsNew.Name = colName + End If + + ' Clear previous content except headers + wsNew.Cells.Clear + ws.Rows(headerRow).Copy wsNew.Rows(headerRow) + + ' Apply filter and copy relevant rows + ws.Range(ws.Cells(headerRow + 1, 1), ws.Cells(lastRow, ws.UsedRange.Columns.Count)).AutoFilter Field:=columnCol, Criteria1:=colValue + + ' Ensure there's data before copying + On Error Resume Next + Set rng = ws.Rows(headerRow + 1 & ":" & lastRow).SpecialCells(xlCellTypeVisible) + On Error GoTo 0 + + + + ' Turn off AutoFilter + ws.AutoFilterMode = False + + ' Adjust column width for better visibility + wsNew.Cells.EntireColumn.AutoFit + + ' Reset worksheet variable + Set wsNew = Nothing + Next colValue + Application.ScreenUpdating = True + + MsgBox "Column reports generated successfully!", vbInformation +End Sub + From f0503dd266f9f72aa6ed2a47de5fa69448e0746d Mon Sep 17 00:00:00 2001 From: kevinowino869 Date: Sun, 2 Mar 2025 14:24:11 +0100 Subject: [PATCH 3/5] Update FilterAndExtractData/FilterAndExtractData.bas --- FilterAndExtractData/FilterAndExtractData.bas | 95 +++++++++---------- 1 file changed, 47 insertions(+), 48 deletions(-) diff --git a/FilterAndExtractData/FilterAndExtractData.bas b/FilterAndExtractData/FilterAndExtractData.bas index 125cb55..30b7146 100644 --- a/FilterAndExtractData/FilterAndExtractData.bas +++ b/FilterAndExtractData/FilterAndExtractData.bas @@ -1,48 +1,47 @@ -Attribute VB_Name = "FilterAndExtractData" -Sub FilterAndExtractData() - Dim wsData As Worksheet, wsDash As Worksheet - Dim lastRow As Long, headerRow As Long - Dim yearFilter As String, programFilter As String, countyFilter As String - Dim rng As Range, filterRange As Range, copyRange As Range - - ' Set references to sheets - Set wsData = ThisWorkbook.Sheets("Datasheet") - Set wsDash = ThisWorkbook.Sheets("Dashboard") - - ' Define last row of data - lastRow = wsData.Cells(wsData.Rows.Count, 1).End(xlUp).Row - headerRow = 1 ' Assuming headers are in row 1 - - ' Get filter values from Dashboard - yearFilter = Trim(wsDash.Range("B7").Value) ' Year filter - programFilter = Trim(wsDash.Range("C7").Value) ' Program filter - countyFilter = Trim(wsDash.Range("D7").Value) ' County filter - - ' Clear previous results - wsDash.Range("A10:L35").ClearContents - - ' Set filter range - Set filterRange = wsData.Range(wsData.Cells(headerRow, 1), wsData.Cells(lastRow, wsData.UsedRange.Columns.Count)) - - ' Apply AutoFilter using the correct column numbers - filterRange.AutoFilter Field:=3, Criteria1:=programFilter ' Program (Column C = 3) - filterRange.AutoFilter Field:=4, Criteria1:=yearFilter ' Year (Column D = 4) - filterRange.AutoFilter Field:=6, Criteria1:=countyFilter ' County (Column F = 6) - - ' Check if visible cells exist after filtering - On Error Resume Next - Set copyRange = filterRange.Offset(1, 0).Resize(filterRange.Rows.Count - 1).SpecialCells(xlCellTypeVisible) - On Error GoTo 0 - - If Not copyRange Is Nothing Then - ' Copy headers - wsData.Rows(headerRow).Copy Destination:=wsDash.Rows(9) ' Paste headers at row 9 - ' Copy filtered data - copyRange.Copy - wsDash.Cells(10, 1).PasteSpecial Paste:=xlPasteValues - wsDash.Cells(10, 1).PasteSpecial Paste:=xlPasteFormats - Application.CutCopyMode = False - Else - MsgBox "No records found for selected filters!", vbExclamation - End If -End Sub +Sub FilterAndExtractData() + Dim wsData As Worksheet, wsDash As Worksheet + Dim lastRow As Long, headerRow As Long + Dim yearFilter As String, programFilter As String, countyFilter As String + Dim rng As Range, filterRange As Range, copyRange As Range + + ' Set references to sheets + Set wsData = ThisWorkbook.Sheets("Datasheet") + Set wsDash = ThisWorkbook.Sheets("Dashboard") + + ' Define last row of data + lastRow = wsData.Cells(wsData.Rows.Count, 1).End(xlUp).Row + headerRow = 1 ' Assuming headers are in row 1 + + ' Get filter values from Dashboard + yearFilter = Trim(wsDash.Range("B7").Value) ' Year filter + programFilter = Trim(wsDash.Range("C7").Value) ' Program filter + countyFilter = Trim(wsDash.Range("D7").Value) ' County filter + + ' Clear previous results + wsDash.Range("A10:ZL100000").ClearContents + + ' Set filter range + Set filterRange = wsData.Range(wsData.Cells(headerRow, 1), wsData.Cells(lastRow, wsData.UsedRange.Columns.Count)) + + ' Apply AutoFilter using the correct column numbers + filterRange.AutoFilter Field:=3, Criteria1:=programFilter ' Program (Column C = 3) + filterRange.AutoFilter Field:=4, Criteria1:=yearFilter ' Year (Column D = 4) + filterRange.AutoFilter Field:=6, Criteria1:=countyFilter ' County (Column F = 6) + + ' Check if visible cells exist after filtering + On Error Resume Next + Set copyRange = filterRange.Offset(1, 0).Resize(filterRange.Rows.Count - 1).SpecialCells(xlCellTypeVisible) + On Error GoTo 0 + + If Not copyRange Is Nothing Then + ' Copy headers + wsData.Rows(headerRow).Copy Destination:=wsDash.Rows(9) ' Paste headers at row 9 + ' Copy filtered data + copyRange.Copy + wsDash.Cells(10, 1).PasteSpecial Paste:=xlPasteValues + wsDash.Cells(10, 1).PasteSpecial Paste:=xlPasteFormats + Application.CutCopyMode = False + Else + MsgBox "No records found for selected filters!", vbExclamation + End If +End Sub From 25e930145c7620b181511b78ac4379c57fc83f71 Mon Sep 17 00:00:00 2001 From: kevinowino869 Date: Sun, 2 Mar 2025 14:25:04 +0100 Subject: [PATCH 4/5] Update ReportPerCounty/ReportPerCounty.bas --- ReportPerCounty/ReportPerCounty.bas | 187 ++++++++++++++-------------- 1 file changed, 93 insertions(+), 94 deletions(-) diff --git a/ReportPerCounty/ReportPerCounty.bas b/ReportPerCounty/ReportPerCounty.bas index 90d2bfc..bfabdc3 100644 --- a/ReportPerCounty/ReportPerCounty.bas +++ b/ReportPerCounty/ReportPerCounty.bas @@ -1,94 +1,93 @@ -Attribute VB_Name = "ReportPerCounty" -Sub GenerateCountyReports() - Dim ws As Worksheet, wsNew As Worksheet - Dim lastRow As Long, countyCol As Long, headerRow As Long - Dim cell As Range, county As Variant - Dim dict As Object - Dim rng As Range - - ' Set worksheet and find last row - Set ws = ThisWorkbook.Sheets("Datasheet") - lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row - headerRow = 1 ' Header row - - ' ?? Dynamically find "County of Residence" column - countyCol = 0 - For Each cell In ws.Rows(headerRow).Cells - If Trim(LCase(cell.Value)) = "county of residence" Then - countyCol = cell.Column - Exit For - End If - Next cell - - ' ?? Check if "County of Residence" column was found - If countyCol = 0 Then - MsgBox "Error: 'County of Residence' column not found!", vbCritical - Exit Sub - End If - - ' Create dictionary to store county names - Set dict = CreateObject("Scripting.Dictionary") - - ' Loop through county column to find unique counties - For Each cell In ws.Range(ws.Cells(headerRow + 1, countyCol), ws.Cells(lastRow, countyCol)) - county = Trim(cell.Value) - If county <> "" And Not dict.exists(county) Then - dict.Add county, Nothing - End If - Next cell - - ' Turn off screen updating for better performance - Application.ScreenUpdating = False - - ' Create sheets for each county and copy relevant data - For Each county In dict.keys - ' Check if sheet exists - On Error Resume Next - Set wsNew = ThisWorkbook.Sheets(county) - On Error GoTo 0 - - ' If sheet doesn't exist, create it - If wsNew Is Nothing Then - Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) - wsNew.Name = county - End If - - ' Clear previous content - wsNew.Cells.Clear - - ' Copy headers - ws.Rows(headerRow).Copy Destination:=wsNew.Rows(headerRow) - - ' Filter and copy data - ws.Range(ws.Cells(headerRow, 1), ws.Cells(lastRow, ws.UsedRange.Columns.Count)).AutoFilter Field:=countyCol, Criteria1:=county - Set rng = ws.Range(ws.Cells(headerRow + 1, 1), ws.Cells(lastRow, ws.UsedRange.Columns.Count)).SpecialCells(xlCellTypeVisible) - - If Not rng Is Nothing Then - rng.Copy - wsNew.Cells(2, 1).PasteSpecial Paste:=xlPasteValues - wsNew.Cells(2, 1).PasteSpecial Paste:=xlPasteFormats - Application.CutCopyMode = False - End If - - ' Turn off AutoFilter - ws.AutoFilterMode = False - - ' Adjust column width - wsNew.Cells.EntireColumn.AutoFit - - ' Remove sheet if no data copied - If wsNew.UsedRange.Rows.Count = 1 Then - Application.DisplayAlerts = False - wsNew.Delete - Application.DisplayAlerts = True - End If - - Set wsNew = Nothing - Next county - - ' Turn on screen updating - Application.ScreenUpdating = True - - MsgBox "County reports generated successfully!", vbInformation -End Sub - +Sub GenerateCountyReports() + Dim ws As Worksheet, wsNew As Worksheet + Dim lastRow As Long, countyCol As Long, headerRow As Long + Dim cell As Range, county As Variant + Dim dict As Object + Dim rng As Range + + ' Set worksheet and find last row + Set ws = ThisWorkbook.Sheets("Datasheet") + lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + headerRow = 1 ' Header row + + ' ?? Dynamically find "County of Residence" column + countyCol = 0 + For Each cell In ws.Rows(headerRow).Cells + If Trim(LCase(cell.Value)) = "county of residence" Then + countyCol = cell.Column + Exit For + End If + Next cell + + ' ?? Check if "County of Residence" column was found + If countyCol = 0 Then + MsgBox "Error: 'County of Residence' column not found!", vbCritical + Exit Sub + End If + + ' Create dictionary to store county names + Set dict = CreateObject("Scripting.Dictionary") + + ' Loop through county column to find unique counties + For Each cell In ws.Range(ws.Cells(headerRow + 1, countyCol), ws.Cells(lastRow, countyCol)) + county = Trim(cell.Value) + If county <> "" And Not dict.exists(county) Then + dict.Add county, Nothing + End If + Next cell + + ' Turn off screen updating for better performance + Application.ScreenUpdating = False + + ' Create sheets for each county and copy relevant data + For Each county In dict.keys + ' Check if sheet exists + On Error Resume Next + Set wsNew = ThisWorkbook.Sheets(county) + On Error GoTo 0 + + ' If sheet doesn't exist, create it + If wsNew Is Nothing Then + Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) + wsNew.Name = county + End If + + ' Clear previous content + wsNew.Cells.Clear + + ' Copy headers + ws.Rows(headerRow).Copy Destination:=wsNew.Rows(headerRow) + + ' Filter and copy data + ws.Range(ws.Cells(headerRow, 1), ws.Cells(lastRow, ws.UsedRange.Columns.Count)).AutoFilter Field:=countyCol, Criteria1:=county + Set rng = ws.Range(ws.Cells(headerRow + 1, 1), ws.Cells(lastRow, ws.UsedRange.Columns.Count)).SpecialCells(xlCellTypeVisible) + + If Not rng Is Nothing Then + rng.Copy + wsNew.Cells(2, 1).PasteSpecial Paste:=xlPasteValues + wsNew.Cells(2, 1).PasteSpecial Paste:=xlPasteFormats + Application.CutCopyMode = False + End If + + ' Turn off AutoFilter + ws.AutoFilterMode = False + + ' Adjust column width + wsNew.Cells.EntireColumn.AutoFit + + ' Remove sheet if no data copied + If wsNew.UsedRange.Rows.Count = 1 Then + Application.DisplayAlerts = False + wsNew.Delete + Application.DisplayAlerts = True + End If + + Set wsNew = Nothing + Next county + + ' Turn on screen updating + Application.ScreenUpdating = True + + MsgBox "County reports generated successfully!", vbInformation +End Sub + From d52839d6cb36314ed18416c5d831b2e8b24814de Mon Sep 17 00:00:00 2001 From: kevinowino869 Date: Sun, 2 Mar 2025 14:26:05 +0100 Subject: [PATCH 5/5] Update ResetFilters/ResetFilters.bas --- ResetFilters/ResetFilters.bas | 67 +++++++++++++++++------------------ 1 file changed, 33 insertions(+), 34 deletions(-) diff --git a/ResetFilters/ResetFilters.bas b/ResetFilters/ResetFilters.bas index 5378a6e..406d1f8 100644 --- a/ResetFilters/ResetFilters.bas +++ b/ResetFilters/ResetFilters.bas @@ -1,34 +1,33 @@ -Attribute VB_Name = "ResetFilters" - -Sub ResetFilters() - Dim wsData As Worksheet, wsDash As Worksheet - Dim lastRow As Long, headerRow As Long - Dim fullRange As Range - - ' Set references to sheets - Set wsData = ThisWorkbook.Sheets("Datasheet") - Set wsDash = ThisWorkbook.Sheets("Dashboard") - - ' Define last row of data - lastRow = wsData.Cells(wsData.Rows.Count, 1).End(xlUp).Row - headerRow = 1 ' Assuming headers are in row 1 - - ' Clear previous results - wsDash.Range("A10:L35").ClearContents - - ' Remove any active filters - If wsData.AutoFilterMode Then wsData.AutoFilterMode = False - - ' Copy all data - Set fullRange = wsData.Range(wsData.Cells(headerRow, 1), wsData.Cells(lastRow, wsData.UsedRange.Columns.Count)) - - ' Copy headers - wsData.Rows(headerRow).Copy Destination:=wsDash.Rows(9) - - ' Copy entire dataset - fullRange.Offset(1, 0).Copy - wsDash.Cells(10, 1).PasteSpecial Paste:=xlPasteValues - wsDash.Cells(10, 1).PasteSpecial Paste:=xlPasteFormats - Application.CutCopyMode = False -End Sub - + +Sub ResetFilters() + Dim wsData As Worksheet, wsDash As Worksheet + Dim lastRow As Long, headerRow As Long + Dim fullRange As Range + + ' Set references to sheets + Set wsData = ThisWorkbook.Sheets("Datasheet") + Set wsDash = ThisWorkbook.Sheets("Dashboard") + + ' Define last row of data + lastRow = wsData.Cells(wsData.Rows.Count, 1).End(xlUp).Row + headerRow = 1 ' Assuming headers are in row 1 + + ' Clear previous results + wsDash.Range("A10:L35").ClearContents + + ' Remove any active filters + If wsData.AutoFilterMode Then wsData.AutoFilterMode = False + + ' Copy all data + Set fullRange = wsData.Range(wsData.Cells(headerRow, 1), wsData.Cells(lastRow, wsData.UsedRange.Columns.Count)) + + ' Copy headers + wsData.Rows(headerRow).Copy Destination:=wsDash.Rows(9) + + ' Copy entire dataset + fullRange.Offset(1, 0).Copy + wsDash.Cells(10, 1).PasteSpecial Paste:=xlPasteValues + wsDash.Cells(10, 1).PasteSpecial Paste:=xlPasteFormats + Application.CutCopyMode = False +End Sub +