Attribute VB_Name = "DetailedReport"
Sub GenerateColumnReports()
    Dim ws As Worksheet, wsNew As Worksheet
    Dim lastRow As Long, columnCol As Long, headerRow As Long
    Dim cell As Range, colValue As Variant
    Dim dict As Object
    Dim rng As Range, copyRange As Range
    Dim colName As String
    
    ' Set worksheet and find last row
    Set ws = ThisWorkbook.Sheets("Datasheet") ' Change to your sheet name
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    columnCol = 3 ' Adjust this to the column number you want to group by
    headerRow = 1 ' Adjust if headers are located on a different row
    
    ' Create dictionary to store unique values
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' Loop through column to find unique values
    For Each cell In ws.Range(ws.Cells(headerRow + 1, columnCol), ws.Cells(lastRow, columnCol))
        colValue = Trim(cell.Value)
        If colValue <> "" And Not dict.exists(colValue) Then
            dict.Add colValue, Nothing
        End If
    Next cell
    
    ' Create sheets for each unique value and copy relevant data
    Application.ScreenUpdating = False
    For Each colValue In dict.keys
        ' Generate a valid sheet name
        colName = colValue
        colName = Replace(colName, "/", "_")
        colName = Replace(colName, "\", "_")
        colName = Replace(colName, "?", "_")
        colName = Replace(colName, "*", "_")
        colName = Replace(colName, "[", "_")
        colName = Replace(colName, "]", "_")
        colName = Replace(colName, ":", "_")
        colName = Left(colName, 31) ' Ensure sheet name is max 31 characters
        
        ' Check if sheet exists
        On Error Resume Next
        Set wsNew = ThisWorkbook.Sheets(colName)
        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 = colName
        End If
        
        ' Clear previous content except headers
        wsNew.Cells.Clear
        ws.Rows(headerRow).Copy wsNew.Rows(headerRow)
        
        ' Apply filter and copy relevant rows
        ws.Range(ws.Cells(headerRow + 1, 1), ws.Cells(lastRow, ws.UsedRange.Columns.Count)).AutoFilter Field:=columnCol, Criteria1:=colValue
        
        ' Ensure there's data before copying
        On Error Resume Next
        Set rng = ws.Rows(headerRow + 1 & ":" & lastRow).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
       
        
        ' Turn off AutoFilter
        ws.AutoFilterMode = False

        ' Adjust column width for better visibility
        wsNew.Cells.EntireColumn.AutoFit

        ' Reset worksheet variable
        Set wsNew = Nothing
    Next colValue
    Application.ScreenUpdating = True
    
    MsgBox "Column reports generated successfully!", vbInformation
End Sub