 Back to jkp-ads.com |
Ron de Bruin
|
 |
|
Back to jkp-ads.com |
Ron de Bruin
|
|
Ron de Bruin decided to remove all Windows Excel content from his website for personal reasons. If you want to know why, head over to rondebruin.nl.
Luckily, Ron was kind enough to allow me to publish all of his Excel content here.
Most of these pages are slightly outdated and may contain links that don 't work. Please inform me if you find such an error and I'll try to fix it.
Kind regards
Jan Karel Pieterse
Most examples on the internet are not so easy to work with for a normal
user like me. I have 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. The examples are created in 2006 but still working
in Excel 2013.
You can download a zip file on the bottom of this page
with two Excel workbooks and the OrderDatabase.mdb to test the examples.
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
And this is the big macro that you not have to change
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
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).
See also this page from Ole P. Erlandsen's
http://www.erlandsendata.no/english/index.php?t=envbadac