diff --git a/DetailedReport/DetailedReport.bas b/DetailedReport/DetailedReport.bas index 98acfa7..90c3872 100644 --- a/DetailedReport/DetailedReport.bas +++ b/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 +