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 FilterAndExtractData/FilterAndExtractData.bas

Browse Source
This commit is contained in:
kevinowino869 2025-03-02 14:24:11 +01:00
parent c7080f0a2f
commit f0503dd266
1 changed files with 47 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

95
FilterAndExtractData/FilterAndExtractData.bas
View File

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