94 lines
3.1 KiB
QBasic
94 lines
3.1 KiB
QBasic
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
|
|
|