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()
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