Option Explicit
'edit these to fit your actual spreadsheet
'===============================================================================
Const cDataSheetName$ = "My Data" 'Name of Data worksheet
Const cName$ = "Name" 'Data Column Header
Const cSurname$ = "Surname" 'Data Column Header
Const cTel$ = "Tel" 'Data Column Header
Const cResultSheetName$ = "My Results" 'Worksheet to paste resuts to
Public Const cReadDateCellAddress$ = "A1" 'Cell where date will be
Const cPasteAnchorAddress$ = "B6" 'Cell to start looking to paste data
'===============================================================================
Public Sub FilterMagic2()
Dim oWb As Workbook, iMonth%, iDay%
Dim dbConn As Object, strConn$ 'http://www.connectionstrings.com
Dim strSQL$, dbRs As Object, rngOutputAnchor As Range
Set oWb = ThisWorkbook '<< I ASSUME THIS WORKBOOK
With oWb.Worksheets(cResultSheetName).Range(cReadDateCellAddress)
iMonth = Month(.Value)
iDay = Day(.Value)
End With
'Make this workbook a database
Set dbConn = CreateObject("ADODB.Connection"): Set dbRs = CreateObject("ADODB.Recordset")
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & oWb.FullName & "';Extended Properties='Excel 12.0 Macro;HDR=YES;IMEX=0';"
dbConn.Open strConn
'Base SQL string
strSQL = "SELECT \Name\, \Surname\, \Tel\ FROM [\SheetName\$] WHERE MONTH(DOB)=\MONTH\ and DAY(DOB)=\DAY\;"
strSQL = Replace(strSQL, "\Name\", cName, vbTextCompare)
strSQL = Replace(strSQL, "\Surname\", cSurname, vbTextCompare)
strSQL = Replace(strSQL, "\Tel\", cTel, vbTextCompare)
strSQL = Replace(strSQL, "\SheetName\", cDataSheetName, vbTextCompare)
strSQL = Replace(strSQL, "\MONTH\", iMonth, vbTextCompare)
strSQL = Replace(strSQL, "\DAY\", iDay, vbTextCompare)
'open record set
dbRs.Open strSQL, strConn
'oWb.Names(strTmpName).Delete
'find open cell to push recordset to worksheet
Set rngOutputAnchor = oWb.Worksheets(cResultSheetName).Range(cPasteAnchorAddress)
Do While Len(rngOutputAnchor.Value) <> 0
Set rngOutputAnchor = rngOutputAnchor.Offset(1)
Loop
rngOutputAnchor.CopyFromRecordset dbRs
CleanUp:
dbRs.Close: Set dbRs = Nothing
dbConn.Close: Set dbConn = Nothing
Set rngOutputAnchor = Nothing
Set oWb = Nothing
Exit Sub
'OTHER SQL CONSTRUCTIONS
'https://www.devhut.net/advanced-sql-to-connect-with-excel-workbooks/
'strSQL = "SELECT * FROM DataTable where YEAR in (1927, 2000, 1885)" ''Named range
'strSQL = "SELECT * FROM [Filter$A1:A100]" 'Range
'strSQL = "SELECT * FROM [Sheet1$]" ''All the data in a sheet
'strSQL = "SELECT * FROM [Excel 12.0 XML;HDR=YES;IMEX=1;database=C:\Docs\LTD.xlsx].[SHEETNAME$XX:XX]" ''Refer to second workbook
End Sub