Copy data from an Access database into Excel with ADO Ron de Bruin (last update 18 Feb 2006)
Go to the Excel tips page
Most examples on the internet are not so easy to work with for a normal user like me.
I will try to change that on this webpage.
We use small macro's that are not so difficult to use/change that call one big macro named GetDataFromAccess.
You can download a zip file on the bottom of this page with two Excel workbooks and the OrderDatabase.mdb.
In one workbook you can find all code from this page and in the other one it is very easy get the info you want
because you can save the criteria (100 or more) and can use Data>Validation cells to select your criteria.
Note: the workbooks and the OrderDatabase.mdb must be in the same folder
In the OrderDatabase.mdb there is a table named Orders with the following fields:
OrderNumber
OrderDate
RequiredDate
ShippedDate
Freight
ShipVia
ShipCountry
ShipName
ShipAddress
ShipCity
ShipRegion
ShipPostalCode
Below you find a few example macro's that you can use to retrieve only the records you want
First
line: Path/name of the Access file, Table name
Second-Eighth line: You can fill in seven criteria, and if you not fill
in any criteria it return all records
The first three criteria are only for Text fields
The fourth and fifth are for numbers fields
The sixth and seventh are for date fields
Line nine: Destination sheet/range
Line ten: Which fields ( * = all), Copy field names, clear all cells
on Destination sheet first
Note: If you use criteria 4-7 (number or Date fields) you can change >, <, >=, <= to get the result you want.
Sub Test1()
'This example retrieves the data for the records in which ShipCountry = Germany
GetDataFromAccess ThisWorkbook.Path & "/OrderDatabase.mdb", "Orders", _
"ShipCountry", "=", "Germany", _
"", "=", "", _
"", "=", "", _
"", ">", "", _
"", "<", "", _
"", ">=", "", _
"", "<=", "", _
Sheets("test").Range("A8"), _
"*", True, True
End Sub
Sub Test2()
'This example retrieves also the data for the records in which ShipCountry = Germany
'It only retrieves this four fields: OrderNumber, ShipName, ShipAddress, ShipPostalCode
'I changed the "*" for WhichFields in the code to the names of the fields
GetDataFromAccess ThisWorkbook.Path & "/OrderDatabase.mdb", "Orders", _
"ShipCountry", "=", "Germany", _
"", "=", "", _
"", "=", "", _
"", ">", "", _
"", "<", "", _
"", ">=", "", _
"", "<=", "", _
Sheets("test").Range("A8"), _
"OrderNumber, ShipName, ShipAddress, ShipPostalCode", True, True
End Sub
Sub Test3()
'This example retrieves the data for the records in which
'ShipCountry = Germany and ShipVia = Speedy Express
GetDataFromAccess ThisWorkbook.Path & "/OrderDatabase.mdb", "Orders", _
"ShipCountry", "=", "Germany", _
"ShipVia", "=", "Speedy Express", _
"", "=", "", _
"", ">", "", _
"", "<", "", _
"", ">=", "", _
"", "<=", "", _
Sheets("test").Range("A8"), _
"*", True, True
End Sub
Sub Test4() 'This example retrieves the data for the records in which 'ShipCountry = Germany and ShipVia = Speedy Express 'and Freight = between 100 and 300
GetDataFromAccess ThisWorkbook.Path & "/OrderDatabase.mdb", "Orders", _
"ShipCountry", "=", "Germany", _
"ShipVia", "=", "Speedy Express", _
"", "=", "", _
"Freight", ">", "100", _
"Freight", "<", "300", _
"", ">=", "", _
"", "<=", "", _
Sheets("test").Range("A8"), _
"*", True, True
End Sub
Sub Test5() 'This example retrieves the data for the records in which 'ShipCountry = Germany and ShipVia = Speedy Express 'and ShippedDate = between 1/1/1998 and 3/1/1998
GetDataFromAccess ThisWorkbook.Path & "/OrderDatabase.mdb", "Orders", _
"ShipCountry", "=", "Germany", _
"ShipVia", "=", "Speedy Express", _
"", "=", "", _
"", ">", "", _
"", "<", "", _
"ShippedDate", ">=", "1/1/1998", _
"ShippedDate", "<=", "3/1/1998", _
Sheets("test").Range("A8"), _
"*", True, True
End Sub
Sub Test6()
'This example retrieves all records
GetDataFromAccess ThisWorkbook.Path & "/OrderDatabase.mdb", "Orders", _
"", "=", "", _
"", "=", "", _
"", "=", "", _
"", ">", "", _
"", "<", "", _
"", ">=", "", _
"", "<=", "", _
Sheets("test").Range("A8"), _
"*", True, True
End Sub
The Big macro
Public Sub GetDataFromAccess(MyDatabaseFilePathAndName As String, MyTable As String, _
MyTableField1 As String, S1 As String, MyFieldValue1 As String, _
MyTableField2 As String, S2 As String, MyFieldValue2 As String, _
MyTableField3 As String, S3 As String, MyFieldValue3 As String, _
MyTableField4 As String, S4 As String, MyFieldValue4 As String, _
MyTableField5 As String, S5 As String, MyFieldValue5 As String, _
MyTableField6 As String, S6 As String, MyFieldValue6 As String, _
MyTableField7 As String, S7 As String, MyFieldValue7 As String, _
DestSheetRange As Range, WhichFields As String, _
FieldNames As Boolean, ClearRange As Boolean)
'Date changed : 18 Feb 2006 'Add the WhichFields option to copy only the fields you want
Dim MyConnection As String
Dim MySQL As String
Dim MyDatabase As Object
Dim col As Integer
Dim I As Integer
Dim str1 As Variant
Dim str2 As Variant
Dim str3 As Variant
'Select the DestSheetRange where you paste the records
Application.Goto DestSheetRange
'If ClearRange = True it clear all cells on that sheet first
If ClearRange Then Range(DestSheetRange.Address, "IV" & Rows.Count).ClearContents
'Create connection string
MyConnection = "Provider=Microsoft.Jet.OLEDB.4.0;"
MyConnection = MyConnection & "Data Source=" & MyDatabaseFilePathAndName & ";"
' Create MySQL string
str1 = Array(MyTableField1, MyTableField2, MyTableField3, MyTableField4, MyTableField5, MyTableField6, MyTableField7)
str2 = Array(S1, S2, S3, S4, S5, S6, S7)
str3 = Array(MyFieldValue1, MyFieldValue2, MyFieldValue3, MyFieldValue4, MyFieldValue5, MyFieldValue6, MyFieldValue7)
MySQL = ""
For I = LBound(str1) To UBound(str1)
If str3(I) <> "" Then
If MySQL = "" Then
If I <= 2 Then
MySQL = "SELECT " & WhichFields & " FROM " & MyTable & " WHERE [" _
& str1(I) & "] " & str2(I) & " '" & str3(I) & "'"
ElseIf I = 3 Or I = 4 Then
MySQL = "SELECT " & WhichFields & " FROM " & MyTable & " WHERE [" _
& str1(I) & "] " & str2(I) & " " & str3(I)
ElseIf I = 5 Or I = 6 Then
MySQL = "SELECT " & WhichFields & " FROM " & MyTable & " WHERE [" _
& str1(I) & "] " & str2(I) & " #" & str3(I) & "#"
End If
Else
If I <= 2 Then
MySQL = MySQL & " and [" & str1(I) & "] " & str2(I) & " '" & str3(I) & "'"
ElseIf I = 3 Or I = 4 Then
MySQL = MySQL & " and [" & str1(I) & "] " & str2(I) & " " & str3(I)
ElseIf I = 5 Or I = 6 Then
MySQL = MySQL & " and [" & str1(I) & "] " & str2(I) & " #" & str3(I) & "#"
End If
End If
End If
Next I
'If MySQL is empty copy all records
If MySQL = "" Then MySQL = "SELECT " & WhichFields & " FROM " & MyTable & ";"
' Open the database and copy the data
On Error GoTo SomethingWrong
Set MyDatabase = CreateObject("adodb.recordset")
MyDatabase.Open MySQL, MyConnection, 0, 1, 1
' Check to make sure we received data and copy the data
If Not MyDatabase.EOF Then
'If FieldNames = True copy the field names and records
'If = False copy only records
If FieldNames Then
For col = 0 To MyDatabase.Fields.Count - 1
DestSheetRange.Offset(0, col).Value = MyDatabase.Fields(col).Name
Next
DestSheetRange.Offset(1, 0).CopyFromRecordset MyDatabase
Else
DestSheetRange.CopyFromRecordset MyDatabase
End If
Else
MsgBox "No records returned from : " & MyDatabaseFilePathAndName, vbCritical
End If
MyDatabase.Close
Set MyDatabase = Nothing
Exit Sub
SomethingWrong:
On Error GoTo 0
Set MyDatabase = Nothing
MsgBox "Error copying data", vbCritical, "Test Access data to Excel"
End Sub
Tip
Instead of enter field values in the code you can
also use a cell value
"ShipVia", "=", Sheets("Sheet1").Range("A2").Value
Check out "Example
to save criteria.xls" where I use data validation cells with unique
values from the fields
and you can also save your criteria (100 or more).
Download
Download the Example workbooks and database
Tips
After you retrieve the records into Excel you can always use
the Excel filters or my EasyFilter Add-in to filter/Copy to a different Sheet/Workbook.
http://www.rondebruin.nl/easyfilter.htm
See also this page from Ole P. Erlandsen's http://www.erlandsendata.no/english/index.php?t=envbadac