79 lines
2.8 KiB
QBasic
79 lines
2.8 KiB
QBasic
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
|
|
|