Upload files to "DetailedReport"

DetailedReport/DetailedReport.bas

@@ -0,0 +1,79 @@
+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
+