agtic/MS_Excel_VBA_Reporting_Template
1
0
Fork 0
forked from nesticti/MS_Excel_VBA_Reporting_Template
Code Pull Requests Activity

Merge pull request '1.10.0' (#4) from mastre into 1.0.10

Browse Source 
Reviewed-on: Nestict_Infotech/MS_Excel_VBA_Reporting_Template#4
This commit is contained in:
nestict 2025-03-02 14:37:20 +01:00
commit 113116565b
5 changed files with 286 additions and 292 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

72
ClearReports/ClearReports.bas
View File

@ -1,37 +1,35 @@
Attribute VB_Name = "ClearReports"
Sub ClearReportsButton()
Dim ws As Worksheet
Dim wsArr As Variant
Dim i As Integer
' Define sheets to keep
wsArr = Array("Dashboard", "Datasheet", "Code")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Loop backwards to avoid deletion issues
For i = ThisWorkbook.Sheets.Count To 1 Step -1
Set ws = ThisWorkbook.Sheets(i)
If Not IsInArray(ws.Name, wsArr) Then
ws.Delete
End If
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "All county reports have been cleared!", vbInformation
End Sub
' Function to check if sheet name is in the list of sheets to keep
Function IsInArray(val As String, arr As Variant) As Boolean
Dim i As Integer
For i = LBound(arr) To UBound(arr)
If arr(i) = val Then
IsInArray = True
Exit Function
End If
Next i
IsInArray = False
End Function
Sub ClearReportsButton()
Dim ws As Worksheet
Dim wsArr As Variant
Dim i As Integer
' Define sheets to keep
wsArr = Array("Dashboard", "Datasheet", "Code")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Loop backwards to avoid deletion issues
For i = ThisWorkbook.Sheets.Count To 1 Step -1
Set ws = ThisWorkbook.Sheets(i)
If Not IsInArray(ws.Name, wsArr) Then
ws.Delete
End If
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "All county reports have been cleared!", vbInformation
End Sub
' Function to check if sheet name is in the list of sheets to keep
Function IsInArray(val As String, arr As Variant) As Boolean
Dim i As Integer
For i = LBound(arr) To UBound(arr)
If arr(i) = val Then
IsInArray = True
Exit Function
End If
Next i
IsInArray = False
End Function

157
DetailedReport/DetailedReport.bas
View File

@ -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

95
FilterAndExtractData/FilterAndExtractData.bas
View File

@ -1,48 +1,47 @@
Attribute VB_Name = "FilterAndExtractData"
Sub FilterAndExtractData()
Dim wsData As Worksheet, wsDash As Worksheet
Dim lastRow As Long, headerRow As Long
Dim yearFilter As String, programFilter As String, countyFilter As String
Dim rng As Range, filterRange As Range, copyRange As Range
' Set references to sheets
Set wsData = ThisWorkbook.Sheets("Datasheet")
Set wsDash = ThisWorkbook.Sheets("Dashboard")
' Define last row of data
lastRow = wsData.Cells(wsData.Rows.Count, 1).End(xlUp).Row
headerRow = 1 ' Assuming headers are in row 1
' Get filter values from Dashboard
yearFilter = Trim(wsDash.Range("B7").Value) ' Year filter
programFilter = Trim(wsDash.Range("C7").Value) ' Program filter
countyFilter = Trim(wsDash.Range("D7").Value) ' County filter
' Clear previous results
wsDash.Range("A10:L35").ClearContents
' Set filter range
Set filterRange = wsData.Range(wsData.Cells(headerRow, 1), wsData.Cells(lastRow, wsData.UsedRange.Columns.Count))
' Apply AutoFilter using the correct column numbers
filterRange.AutoFilter Field:=3, Criteria1:=programFilter ' Program (Column C = 3)
filterRange.AutoFilter Field:=4, Criteria1:=yearFilter ' Year (Column D = 4)
filterRange.AutoFilter Field:=6, Criteria1:=countyFilter ' County (Column F = 6)
' Check if visible cells exist after filtering
On Error Resume Next
Set copyRange = filterRange.Offset(1, 0).Resize(filterRange.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not copyRange Is Nothing Then
' Copy headers
wsData.Rows(headerRow).Copy Destination:=wsDash.Rows(9) ' Paste headers at row 9
' Copy filtered data
copyRange.Copy
wsDash.Cells(10, 1).PasteSpecial Paste:=xlPasteValues
wsDash.Cells(10, 1).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
Else
MsgBox "No records found for selected filters!", vbExclamation
End If
End Sub
Sub FilterAndExtractData()
Dim wsData As Worksheet, wsDash As Worksheet
Dim lastRow As Long, headerRow As Long
Dim yearFilter As String, programFilter As String, countyFilter As String
Dim rng As Range, filterRange As Range, copyRange As Range
' Set references to sheets
Set wsData = ThisWorkbook.Sheets("Datasheet")
Set wsDash = ThisWorkbook.Sheets("Dashboard")
' Define last row of data
lastRow = wsData.Cells(wsData.Rows.Count, 1).End(xlUp).Row
headerRow = 1 ' Assuming headers are in row 1
' Get filter values from Dashboard
yearFilter = Trim(wsDash.Range("B7").Value) ' Year filter
programFilter = Trim(wsDash.Range("C7").Value) ' Program filter
countyFilter = Trim(wsDash.Range("D7").Value) ' County filter
' Clear previous results
wsDash.Range("A10:ZL100000").ClearContents
' Set filter range
Set filterRange = wsData.Range(wsData.Cells(headerRow, 1), wsData.Cells(lastRow, wsData.UsedRange.Columns.Count))
' Apply AutoFilter using the correct column numbers
filterRange.AutoFilter Field:=3, Criteria1:=programFilter ' Program (Column C = 3)
filterRange.AutoFilter Field:=4, Criteria1:=yearFilter ' Year (Column D = 4)
filterRange.AutoFilter Field:=6, Criteria1:=countyFilter ' County (Column F = 6)
' Check if visible cells exist after filtering
On Error Resume Next
Set copyRange = filterRange.Offset(1, 0).Resize(filterRange.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not copyRange Is Nothing Then
' Copy headers
wsData.Rows(headerRow).Copy Destination:=wsDash.Rows(9) ' Paste headers at row 9
' Copy filtered data
copyRange.Copy
wsDash.Cells(10, 1).PasteSpecial Paste:=xlPasteValues
wsDash.Cells(10, 1).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
Else
MsgBox "No records found for selected filters!", vbExclamation
End If
End Sub

187
ReportPerCounty/ReportPerCounty.bas
View File

@ -1,94 +1,93 @@
Attribute VB_Name = "ReportPerCounty"
Sub GenerateCountyReports()
Dim ws As Worksheet, wsNew As Worksheet
Dim lastRow As Long, countyCol As Long, headerRow As Long
Dim cell As Range, county As Variant
Dim dict As Object
Dim rng As Range
' Set worksheet and find last row
Set ws = ThisWorkbook.Sheets("Datasheet")
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
headerRow = 1 ' Header row
' ?? Dynamically find "County of Residence" column
countyCol = 0
For Each cell In ws.Rows(headerRow).Cells
If Trim(LCase(cell.Value)) = "county of residence" Then
countyCol = cell.Column
Exit For
End If
Next cell
' ?? Check if "County of Residence" column was found
If countyCol = 0 Then
MsgBox "Error: 'County of Residence' column not found!", vbCritical
Exit Sub
End If
' Create dictionary to store county names
Set dict = CreateObject("Scripting.Dictionary")
' Loop through county column to find unique counties
For Each cell In ws.Range(ws.Cells(headerRow + 1, countyCol), ws.Cells(lastRow, countyCol))
county = Trim(cell.Value)
If county <> "" And Not dict.exists(county) Then
dict.Add county, Nothing
End If
Next cell
' Turn off screen updating for better performance
Application.ScreenUpdating = False
' Create sheets for each county and copy relevant data
For Each county In dict.keys
' Check if sheet exists
On Error Resume Next
Set wsNew = ThisWorkbook.Sheets(county)
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 = county
End If
' Clear previous content
wsNew.Cells.Clear
' Copy headers
ws.Rows(headerRow).Copy Destination:=wsNew.Rows(headerRow)
' Filter and copy data
ws.Range(ws.Cells(headerRow, 1), ws.Cells(lastRow, ws.UsedRange.Columns.Count)).AutoFilter Field:=countyCol, Criteria1:=county
Set rng = ws.Range(ws.Cells(headerRow + 1, 1), ws.Cells(lastRow, ws.UsedRange.Columns.Count)).SpecialCells(xlCellTypeVisible)
If Not rng Is Nothing Then
rng.Copy
wsNew.Cells(2, 1).PasteSpecial Paste:=xlPasteValues
wsNew.Cells(2, 1).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End If
' Turn off AutoFilter
ws.AutoFilterMode = False
' Adjust column width
wsNew.Cells.EntireColumn.AutoFit
' Remove sheet if no data copied
If wsNew.UsedRange.Rows.Count = 1 Then
Application.DisplayAlerts = False
wsNew.Delete
Application.DisplayAlerts = True
End If
Set wsNew = Nothing
Next county
' Turn on screen updating
Application.ScreenUpdating = True
MsgBox "County reports generated successfully!", vbInformation
End Sub
Sub GenerateCountyReports()
Dim ws As Worksheet, wsNew As Worksheet
Dim lastRow As Long, countyCol As Long, headerRow As Long
Dim cell As Range, county As Variant
Dim dict As Object
Dim rng As Range
' Set worksheet and find last row
Set ws = ThisWorkbook.Sheets("Datasheet")
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
headerRow = 1 ' Header row
' ?? Dynamically find "County of Residence" column
countyCol = 0
For Each cell In ws.Rows(headerRow).Cells
If Trim(LCase(cell.Value)) = "county of residence" Then
countyCol = cell.Column
Exit For
End If
Next cell
' ?? Check if "County of Residence" column was found
If countyCol = 0 Then
MsgBox "Error: 'County of Residence' column not found!", vbCritical
Exit Sub
End If
' Create dictionary to store county names
Set dict = CreateObject("Scripting.Dictionary")
' Loop through county column to find unique counties
For Each cell In ws.Range(ws.Cells(headerRow + 1, countyCol), ws.Cells(lastRow, countyCol))
county = Trim(cell.Value)
If county <> "" And Not dict.exists(county) Then
dict.Add county, Nothing
End If
Next cell
' Turn off screen updating for better performance
Application.ScreenUpdating = False
' Create sheets for each county and copy relevant data
For Each county In dict.keys
' Check if sheet exists
On Error Resume Next
Set wsNew = ThisWorkbook.Sheets(county)
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 = county
End If
' Clear previous content
wsNew.Cells.Clear
' Copy headers
ws.Rows(headerRow).Copy Destination:=wsNew.Rows(headerRow)
' Filter and copy data
ws.Range(ws.Cells(headerRow, 1), ws.Cells(lastRow, ws.UsedRange.Columns.Count)).AutoFilter Field:=countyCol, Criteria1:=county
Set rng = ws.Range(ws.Cells(headerRow + 1, 1), ws.Cells(lastRow, ws.UsedRange.Columns.Count)).SpecialCells(xlCellTypeVisible)
If Not rng Is Nothing Then
rng.Copy
wsNew.Cells(2, 1).PasteSpecial Paste:=xlPasteValues
wsNew.Cells(2, 1).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End If
' Turn off AutoFilter
ws.AutoFilterMode = False
' Adjust column width
wsNew.Cells.EntireColumn.AutoFit
' Remove sheet if no data copied
If wsNew.UsedRange.Rows.Count = 1 Then
Application.DisplayAlerts = False
wsNew.Delete
Application.DisplayAlerts = True
End If
Set wsNew = Nothing
Next county
' Turn on screen updating
Application.ScreenUpdating = True
MsgBox "County reports generated successfully!", vbInformation
End Sub

67
ResetFilters/ResetFilters.bas
View File

@ -1,34 +1,33 @@
Attribute VB_Name = "ResetFilters"
Sub ResetFilters()
Dim wsData As Worksheet, wsDash As Worksheet
Dim lastRow As Long, headerRow As Long
Dim fullRange As Range
' Set references to sheets
Set wsData = ThisWorkbook.Sheets("Datasheet")
Set wsDash = ThisWorkbook.Sheets("Dashboard")
' Define last row of data
lastRow = wsData.Cells(wsData.Rows.Count, 1).End(xlUp).Row
headerRow = 1 ' Assuming headers are in row 1
' Clear previous results
wsDash.Range("A10:L35").ClearContents
' Remove any active filters
If wsData.AutoFilterMode Then wsData.AutoFilterMode = False
' Copy all data
Set fullRange = wsData.Range(wsData.Cells(headerRow, 1), wsData.Cells(lastRow, wsData.UsedRange.Columns.Count))
' Copy headers
wsData.Rows(headerRow).Copy Destination:=wsDash.Rows(9)
' Copy entire dataset
fullRange.Offset(1, 0).Copy
wsDash.Cells(10, 1).PasteSpecial Paste:=xlPasteValues
wsDash.Cells(10, 1).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End Sub
Sub ResetFilters()
Dim wsData As Worksheet, wsDash As Worksheet
Dim lastRow As Long, headerRow As Long
Dim fullRange As Range
' Set references to sheets
Set wsData = ThisWorkbook.Sheets("Datasheet")
Set wsDash = ThisWorkbook.Sheets("Dashboard")
' Define last row of data
lastRow = wsData.Cells(wsData.Rows.Count, 1).End(xlUp).Row
headerRow = 1 ' Assuming headers are in row 1
' Clear previous results
wsDash.Range("A10:L35").ClearContents
' Remove any active filters
If wsData.AutoFilterMode Then wsData.AutoFilterMode = False
' Copy all data
Set fullRange = wsData.Range(wsData.Cells(headerRow, 1), wsData.Cells(lastRow, wsData.UsedRange.Columns.Count))
' Copy headers
wsData.Rows(headerRow).Copy Destination:=wsDash.Rows(9)
' Copy entire dataset
fullRange.Offset(1, 0).Copy
wsDash.Cells(10, 1).PasteSpecial Paste:=xlPasteValues
wsDash.Cells(10, 1).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End Sub