Sub Extract_The_Data_From_Access_To_Excel()

'Open Access DataBase File
Dim AccessFile As String
AccessFile = Application.GetOpenFilename

'Open Excel Workbook
Dim ExcelFile As String
ExcelFile = Application.GetOpenFilename
Workbooks.Open Filename:=ExcelFile, UpdateLinks:=False

'Define the Workbook
Dim DestWkb As Workbook
Set DestWkb = ActiveWorkbook

'Define the worksheet
Dim SH As Worksheet
Set SH = DestWkb.Sheets("Sheet1")
SH.Range(Cells(2, 1), Cells(SH.Range("A" & Rows.Count).End(xlUp).Row, SH.UsedRange.Columns.Count)).Clear

'Open connection
Dim cn As New ADODB.Connection
cn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & AccessFile & ";" & _
"User Id=admin;Password="
cn.Open

'Define the Recordset
Dim rs As New ADODB.Recordset
'Activating the connection
Set rs.ActiveConnection = cn

'Create SQL Query
Query = "Select * from Sales where Item = 'Apple'"

'Open the Record set
rs.Open Query

'Copy the record set in the workbook
SH.Range("A2").CopyFromRecordset rs
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
DestWkb.Save
DestWkb.Close
Set DestWkb = Nothing
End Sub