Compare commits
13 Commits
| Author | SHA1 | Date | |
|---|---|---|---|
| affc598864 | |||
| 07cb2e64e4 | |||
| d52839d6cb | |||
| 25e930145c | |||
| f0503dd266 | |||
| c7080f0a2f | |||
| b2e084bd10 | |||
| fa3d0e8f23 | |||
| 4af67db419 | |||
| 0e96b147de | |||
| 2081b52e43 | |||
| 134e072d21 | |||
| cef4ee4305 |
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
145
Manual
Normal file
145
Manual
Normal file
@ -0,0 +1,145 @@
|
||||
**User Manual for Excel Filtering System**
|
||||
|
||||
---
|
||||
|
||||
## **Introduction**
|
||||
This manual provides step-by-step instructions on how to use the Excel-based filtering system to generate reports based on selected criteria, such as Year, Program, and County. It also explains how to reset filters and clear reports.
|
||||
|
||||
---
|
||||
|
||||
## **1. System Components**
|
||||
|
||||
### **1.1 Dashboard Sheet**
|
||||
- The main interface for interacting with the data.
|
||||
- Contains filter options and action buttons.
|
||||
- Displays filtered results from the "Datasheet".
|
||||
|
||||
### **1.2 Datasheet**
|
||||
- Stores the raw data that is used for filtering and reporting.
|
||||
- Contains columns such as ID, Beneficiary Name, Program, Year, Business Type/Course, and County of Residence.
|
||||
|
||||
### **1.3 VBA Code Module**
|
||||
- Automates data extraction based on selected filters.
|
||||
- Provides functionalities such as generating reports, resetting filters, and clearing reports.
|
||||
|
||||
---
|
||||
|
||||
## **2. Using the System**
|
||||
|
||||
### **2.1 Applying Filters**
|
||||
1. **Navigate to the Dashboard sheet.**
|
||||
2. **Select filter values:**
|
||||
- Choose a Year from the dropdown under "Year".
|
||||
- Select a Program from the dropdown under "Program".
|
||||
- Select a County from the dropdown under "County".
|
||||
3. **Click the "Apply Filters" button.**
|
||||
- The system will filter data from the "Datasheet" and display results in the Dashboard.
|
||||
- If no matching records are found, a message box will notify you.
|
||||
|
||||
### **2.2 Resetting Filters**
|
||||
1. **Click the "Reset Filters" button.**
|
||||
2. This will remove all applied filters and display the entire dataset in the Dashboard.
|
||||
|
||||
### **2.3 Generating County Reports**
|
||||
1. **Ensure filters are correctly set (Year, Program, County).**
|
||||
2. **Click the "Generate County Reports" button.**
|
||||
3. The system will extract and display relevant data in the Dashboard.
|
||||
|
||||
### **2.4 Clearing Reports**
|
||||
1. **Click the "Reset/Clear Reporting" button.**
|
||||
2. This will clear all previously displayed data from the Dashboard.
|
||||
|
||||
---
|
||||
|
||||
## **3. Technical Details**
|
||||
|
||||
### **3.1 VBA Code for Filtering Data**
|
||||
The VBA macro automatically applies filters and copies the relevant data to the Dashboard.
|
||||
|
||||
```vba
|
||||
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 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
|
||||
|
||||
' Get filter values from Dashboard
|
||||
yearFilter = wsDash.Range("B7").Value
|
||||
programFilter = wsDash.Range("C7").Value
|
||||
countyFilter = wsDash.Range("D7").Value
|
||||
|
||||
' 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
|
||||
filterRange.AutoFilter Field:=3, Criteria1:=yearFilter
|
||||
filterRange.AutoFilter Field:=2, Criteria1:=programFilter
|
||||
filterRange.AutoFilter Field:=5, Criteria1:=countyFilter
|
||||
|
||||
' Check if visible cells exist
|
||||
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
|
||||
wsData.Rows(headerRow).Copy Destination:=wsDash.Rows(9)
|
||||
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
|
||||
|
||||
' Turn off AutoFilter
|
||||
wsData.AutoFilterMode = False
|
||||
End Sub
|
||||
```
|
||||
|
||||
### **3.2 VBA Code for Clearing Reports**
|
||||
```vba
|
||||
Sub ClearReportsButton()
|
||||
Dim ws As Worksheet
|
||||
Application.ScreenUpdating = False
|
||||
Application.DisplayAlerts = False
|
||||
|
||||
For Each ws In ThisWorkbook.Sheets
|
||||
If ws.Name <> "Dashboard" And ws.Name <> "Datasheet" And ws.Name <> "Code" Then
|
||||
ws.Delete
|
||||
End If
|
||||
Next ws
|
||||
|
||||
Application.DisplayAlerts = True
|
||||
Application.ScreenUpdating = True
|
||||
MsgBox "All county reports have been cleared!", vbInformation
|
||||
End Sub
|
||||
```
|
||||
|
||||
---
|
||||
|
||||
## **4. Troubleshooting**
|
||||
|
||||
| **Issue** | **Solution** |
|
||||
|-----------|-------------|
|
||||
| "No records found for selected filters!" | Ensure the selected filter values exist in the "Datasheet". |
|
||||
| "Error when applying filters" | Check if the headers in "Datasheet" match the VBA filter fields. |
|
||||
| "Clear Reports button not working" | Ensure the correct sheet names are being referenced in the code. |
|
||||
|
||||
---
|
||||
|
||||
## **5. Conclusion**
|
||||
This Excel filtering system allows users to efficiently filter and extract data based on selected criteria. With the provided VBA scripts, users can automate data extraction, reset filters, and clear reports easily. If any modifications are needed, update the VBA code accordingly.
|
||||
|
||||
For further assistance, please contact the system administrator.
|
||||
|
||||
@ -15,7 +15,7 @@ The **MS Excel VBA Reporting Template** is designed to automate the generation o
|
||||
- **Error Handling**: Includes basic error handling mechanisms for smoother operation.
|
||||
|
||||
## Prerequisites
|
||||
- Microsoft Excel (2016 or later recommended)
|
||||
- Microsoft Excel (2010 or later recommended)
|
||||
- Macros enabled (Ensure that macro settings allow execution of VBA scripts)
|
||||
- Basic knowledge of VBA (optional but beneficial for customization)
|
||||
|
||||
@ -49,5 +49,5 @@ The **MS Excel VBA Reporting Template** is designed to automate the generation o
|
||||
This template is open-source and can be modified as per your requirements. Ensure proper credits are given when shared publicly.
|
||||
|
||||
## Contact
|
||||
For any issues or custom modifications, feel free to reach out via email at `support@nestict.com.com`.
|
||||
For any issues or custom modifications, feel free to reach out via email at `support@nestict.com`.
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user