From 25e930145c7620b181511b78ac4379c57fc83f71 Mon Sep 17 00:00:00 2001 From: kevinowino869 Date: Sun, 2 Mar 2025 14:25:04 +0100 Subject: [PATCH] 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 +