Update DetailedReport/DetailedReport.bas

DetailedReport/DetailedReport.bas

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