diff --git a/DetailedReport/DetailedReport.bas b/DetailedReport/DetailedReport.bas new file mode 100644 index 0000000..98acfa7 --- /dev/null +++ b/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 +