nesticti/MS_Excel_VBA_Reporting_Template
nesticti/MS_Excel_VBA_Reporting_Template
1
0
Fork 1
Code Issues 1 Pull Requests Actions Packages Projects 1 Releases 3 Wiki Activity

Update ReportPerCounty/ReportPerCounty.bas

Browse Source
This commit is contained in:
kevinowino869 2025-03-02 14:25:04 +01:00
parent f0503dd266
commit 25e930145c
1 changed files with 93 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

187
ReportPerCounty/ReportPerCounty.bas
View File

@ -1,94 +1,93 @@
Attribute VB_Name = "ReportPerCounty" Sub GenerateCountyReports()
Sub GenerateCountyReports() Dim ws As Worksheet, wsNew As Worksheet
Dim ws As Worksheet, wsNew As Worksheet Dim lastRow As Long, countyCol As Long, headerRow As Long
Dim lastRow As Long, countyCol As Long, headerRow As Long Dim cell As Range, county As Variant
Dim cell As Range, county As Variant Dim dict As Object
Dim dict As Object Dim rng As Range
Dim rng As Range
' Set worksheet and find last row
' Set worksheet and find last row Set ws = ThisWorkbook.Sheets("Datasheet")
Set ws = ThisWorkbook.Sheets("Datasheet") lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row headerRow = 1 ' Header row
headerRow = 1 ' Header row
' ?? Dynamically find "County of Residence" column
' ?? Dynamically find "County of Residence" column countyCol = 0
countyCol = 0 For Each cell In ws.Rows(headerRow).Cells
For Each cell In ws.Rows(headerRow).Cells If Trim(LCase(cell.Value)) = "county of residence" Then
If Trim(LCase(cell.Value)) = "county of residence" Then countyCol = cell.Column
countyCol = cell.Column Exit For
Exit For End If
End If Next cell
Next cell
' ?? Check if "County of Residence" column was found
' ?? Check if "County of Residence" column was found If countyCol = 0 Then
If countyCol = 0 Then MsgBox "Error: 'County of Residence' column not found!", vbCritical
MsgBox "Error: 'County of Residence' column not found!", vbCritical Exit Sub
Exit Sub End If
End If
' Create dictionary to store county names
' Create dictionary to store county names Set dict = CreateObject("Scripting.Dictionary")
Set dict = CreateObject("Scripting.Dictionary")
' Loop through county column to find unique counties
' Loop through county column to find unique counties For Each cell In ws.Range(ws.Cells(headerRow + 1, countyCol), ws.Cells(lastRow, countyCol))
For Each cell In ws.Range(ws.Cells(headerRow + 1, countyCol), ws.Cells(lastRow, countyCol)) county = Trim(cell.Value)
county = Trim(cell.Value) If county <> "" And Not dict.exists(county) Then
If county <> "" And Not dict.exists(county) Then dict.Add county, Nothing
dict.Add county, Nothing End If
End If Next cell
Next cell
' Turn off screen updating for better performance
' Turn off screen updating for better performance Application.ScreenUpdating = False
Application.ScreenUpdating = False
' Create sheets for each county and copy relevant data
' Create sheets for each county and copy relevant data For Each county In dict.keys
For Each county In dict.keys ' Check if sheet exists
' Check if sheet exists On Error Resume Next
On Error Resume Next Set wsNew = ThisWorkbook.Sheets(county)
Set wsNew = ThisWorkbook.Sheets(county) On Error GoTo 0
On Error GoTo 0
' If sheet doesn't exist, create it
' If sheet doesn't exist, create it If wsNew Is Nothing Then
If wsNew Is Nothing Then Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) wsNew.Name = county
wsNew.Name = county End If
End If
' Clear previous content
' Clear previous content wsNew.Cells.Clear
wsNew.Cells.Clear
' Copy headers
' Copy headers ws.Rows(headerRow).Copy Destination:=wsNew.Rows(headerRow)
ws.Rows(headerRow).Copy Destination:=wsNew.Rows(headerRow)
' Filter and copy data
' Filter and copy data ws.Range(ws.Cells(headerRow, 1), ws.Cells(lastRow, ws.UsedRange.Columns.Count)).AutoFilter Field:=countyCol, Criteria1:=county
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)
Set rng = ws.Range(ws.Cells(headerRow + 1, 1), ws.Cells(lastRow, ws.UsedRange.Columns.Count)).SpecialCells(xlCellTypeVisible)
If Not rng Is Nothing Then
If Not rng Is Nothing Then rng.Copy
rng.Copy wsNew.Cells(2, 1).PasteSpecial Paste:=xlPasteValues
wsNew.Cells(2, 1).PasteSpecial Paste:=xlPasteValues wsNew.Cells(2, 1).PasteSpecial Paste:=xlPasteFormats
wsNew.Cells(2, 1).PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = False
Application.CutCopyMode = False End If
End If
' Turn off AutoFilter
' Turn off AutoFilter ws.AutoFilterMode = False
ws.AutoFilterMode = False
' Adjust column width
' Adjust column width wsNew.Cells.EntireColumn.AutoFit
wsNew.Cells.EntireColumn.AutoFit
' Remove sheet if no data copied
' Remove sheet if no data copied If wsNew.UsedRange.Rows.Count = 1 Then
If wsNew.UsedRange.Rows.Count = 1 Then Application.DisplayAlerts = False
Application.DisplayAlerts = False wsNew.Delete
wsNew.Delete Application.DisplayAlerts = True
Application.DisplayAlerts = True End If
End If
Set wsNew = Nothing
Set wsNew = Nothing Next county
Next county
' Turn on screen updating
' Turn on screen updating Application.ScreenUpdating = True
Application.ScreenUpdating = True
MsgBox "County reports generated successfully!", vbInformation
MsgBox "County reports generated successfully!", vbInformation End Sub
End Sub