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