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

Compare commits

base: nesticti:113116565bfaa1719199b702011eedf1930d737b
Branches Tags
nesticti:mastre
nesticti:1.0.10
nesticti:3.0
nesticti:1.0.9
nesticti:1.0.8
nesticti:ui
nesticti:vba
nesticti:Reporting
..
compare: nesticti:4af67db419772ed13208bbe040654d0b697b3be7
Branches Tags
nesticti:1.0.10
nesticti:3.0
nesticti:mastre
nesticti:1.0.9
nesticti:1.0.8
nesticti:ui
nesticti:vba
nesticti:Reporting

No commits in common. "113116565bfaa1719199b702011eedf1930d737b" and "4af67db419772ed13208bbe040654d0b697b3be7" have entirely different histories.
113116565b ... 4af67db419

5 changed files with 292 additions and 286 deletions
Show Stats Expand all files Collapse all files

72
ClearReports/ClearReports.bas
View File

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

157
DetailedReport/DetailedReport.bas
View File

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

95
FilterAndExtractData/FilterAndExtractData.bas
View File

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

187
ReportPerCounty/ReportPerCounty.bas
View File

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

67
ResetFilters/ResetFilters.bas
View File

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