From 1efb82d54e4a55095c7fa191a91e7769ea435148 Mon Sep 17 00:00:00 2001
From: nestict <icttechnest@gmail.com>
Date: Thu, 27 Feb 2025 19:36:15 +0100
Subject: [PATCH] Upload files to "ReportPerCounty"

---
 ReportPerCounty/ReportPerCounty.bas | 94 +++++++++++++++++++++++++++++
 1 file changed, 94 insertions(+)
 create mode 100644 ReportPerCounty/ReportPerCounty.bas

diff --git a/ReportPerCounty/ReportPerCounty.bas b/ReportPerCounty/ReportPerCounty.bas
new file mode 100644
index 0000000..90d2bfc
--- /dev/null
+++ b/ReportPerCounty/ReportPerCounty.bas
@@ -0,0 +1,94 @@
+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
+