Code: Select all
Sub Filter()
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim strSQL As String
Dim ws As Worksheet
Dim wss As Worksheet
Dim rngMyRange As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
Set ws = Worksheets("results")
Set wss = Worksheets("Criteria")
Set rngMyRange = wss.Range("A1:A85")
ws.Range("A5:G1048576").ClearContents
Set cnn = New ADODB.Connection
cnn.Open "Provider=Microsoft.ace.OLEDB.12.0; " & _
"Data Source=E:\IL\Database.accdb;"
Set rst = New ADODB.Recordset
strSQL = "SELECT [Product Name],[Product Category],[Location],[Price] FROM Ptable WHERE [Product Name]=" & rngMyRange
rst.Open strSQL, cnn, adOpenKeyset, adLockOptimistic, adCmdText
ws.Range("D5").CopyFromRecordset rst
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub