Sub Extract_Required_Range_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
rs.Open "Select * from Sales"

Dim R As Long
R = 2
Do Until rs.EOF

'SH.Cells(R, 1) = rs.Fields("Item")
SH.Cells(R, 1) = rs.Fields(0).Value
SH.Cells(R, 2) = rs.Fields(1).Value
SH.Cells(R, 3) = rs.Fields(2).Value
SH.Cells(R, 4) = rs.Fields(3).Value
SH.Cells(R, 5) = rs.Fields(4).Value
SH.Cells(R, 6) = rs.Fields(5).Value

rs.MoveNext
R = R + 1
Loop

rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
DestWkb.Save
DestWkb.Close
Set DestWkb = Nothing

MsgBox "Hi Automation completed"
End Sub