From fba2efa1e7d5e7f8b130ba1891be2370c52baa63 Mon Sep 17 00:00:00 2001
From: nestict <icttechnest@gmail.com>
Date: Thu, 27 Feb 2025 19:37:28 +0100
Subject: [PATCH] Upload files to "FilterAndExtractData"

---
 FilterAndExtractData/FilterAndExtractData.bas | 48 +++++++++++++++++++
 1 file changed, 48 insertions(+)
 create mode 100644 FilterAndExtractData/FilterAndExtractData.bas

diff --git a/FilterAndExtractData/FilterAndExtractData.bas b/FilterAndExtractData/FilterAndExtractData.bas
new file mode 100644
index 0000000..125cb55
--- /dev/null
+++ b/FilterAndExtractData/FilterAndExtractData.bas
@@ -0,0 +1,48 @@
+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