nesticti/MS_Excel_VBA_Reporting_Template
nesticti/MS_Excel_VBA_Reporting_Template
1
0
Fork 1
Code Issues 1 Pull Requests Actions Packages Projects 1 Releases 3 Wiki Activity

Update DetailedReport/DetailedReport.bas

Browse Source
This commit is contained in:
kevinowino869 2025-03-02 14:22:49 +01:00
parent b2e084bd10
commit c7080f0a2f
1 changed files with 78 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

157
DetailedReport/DetailedReport.bas
View File

@ -1,79 +1,78 @@
Attribute VB_Name = "DetailedReport" Sub GenerateColumnReports()
Sub GenerateColumnReports() Dim ws As Worksheet, wsNew As Worksheet
Dim ws As Worksheet, wsNew As Worksheet Dim lastRow As Long, columnCol As Long, headerRow As Long
Dim lastRow As Long, columnCol As Long, headerRow As Long Dim cell As Range, colValue As Variant
Dim cell As Range, colValue As Variant Dim dict As Object
Dim dict As Object Dim rng As Range, copyRange As Range
Dim rng As Range, copyRange As Range Dim colName As String
Dim colName As String
' Set worksheet and find last row
' Set worksheet and find last row Set ws = ThisWorkbook.Sheets("Datasheet") ' Change to your sheet name
Set ws = ThisWorkbook.Sheets("Datasheet") ' Change to your sheet name lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row columnCol = 3 ' Adjust this to the column number you want to group by
columnCol = 3 ' Adjust this to the column number you want to group by headerRow = 1 ' Adjust if headers are located on a different row
headerRow = 1 ' Adjust if headers are located on a different row
' Create dictionary to store unique values
' Create dictionary to store unique values Set dict = CreateObject("Scripting.Dictionary")
Set dict = CreateObject("Scripting.Dictionary")
' Loop through column to find unique values
' Loop through column to find unique values For Each cell In ws.Range(ws.Cells(headerRow + 1, columnCol), ws.Cells(lastRow, columnCol))
For Each cell In ws.Range(ws.Cells(headerRow + 1, columnCol), ws.Cells(lastRow, columnCol)) colValue = Trim(cell.Value)
colValue = Trim(cell.Value) If colValue <> "" And Not dict.exists(colValue) Then
If colValue <> "" And Not dict.exists(colValue) Then dict.Add colValue, Nothing
dict.Add colValue, Nothing End If
End If Next cell
Next cell
' Create sheets for each unique value and copy relevant data
' Create sheets for each unique value and copy relevant data Application.ScreenUpdating = False
Application.ScreenUpdating = False For Each colValue In dict.keys
For Each colValue In dict.keys ' Generate a valid sheet name
' Generate a valid sheet name colName = colValue
colName = colValue colName = Replace(colName, "/", "_")
colName = Replace(colName, "/", "_") colName = Replace(colName, "\", "_")
colName = Replace(colName, "\", "_") colName = Replace(colName, "?", "_")
colName = Replace(colName, "?", "_") colName = Replace(colName, "*", "_")
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
colName = Left(colName, 31) ' Ensure sheet name is max 31 characters
' Check if sheet exists
' Check if sheet exists On Error Resume Next
On Error Resume Next Set wsNew = ThisWorkbook.Sheets(colName)
Set wsNew = ThisWorkbook.Sheets(colName) On Error GoTo 0
On Error GoTo 0
' If sheet doesn't exist, create it
' If sheet doesn't exist, create it If wsNew Is Nothing Then
If wsNew Is Nothing Then Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) wsNew.Name = colName
wsNew.Name = colName End If
End If
' Clear previous content except headers
' Clear previous content except headers wsNew.Cells.Clear
wsNew.Cells.Clear ws.Rows(headerRow).Copy wsNew.Rows(headerRow)
ws.Rows(headerRow).Copy wsNew.Rows(headerRow)
' Apply filter and copy relevant rows
' 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
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
' Ensure there's data before copying On Error Resume Next
On Error Resume Next Set rng = ws.Rows(headerRow + 1 & ":" & lastRow).SpecialCells(xlCellTypeVisible)
Set rng = ws.Rows(headerRow + 1 & ":" & lastRow).SpecialCells(xlCellTypeVisible) On Error GoTo 0
On Error GoTo 0
' Turn off AutoFilter
' Turn off AutoFilter ws.AutoFilterMode = False
ws.AutoFilterMode = False
' Adjust column width for better visibility
' Adjust column width for better visibility wsNew.Cells.EntireColumn.AutoFit
wsNew.Cells.EntireColumn.AutoFit
' Reset worksheet variable
' Reset worksheet variable Set wsNew = Nothing
Set wsNew = Nothing Next colValue
Next colValue Application.ScreenUpdating = True
Application.ScreenUpdating = True
MsgBox "Column reports generated successfully!", vbInformation
MsgBox "Column reports generated successfully!", vbInformation End Sub
End Sub