First test the code in the "Code Website.xls"
Always start with a simple example
--
Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm
A space in the field name is no problem
If my Examples are working OK then I have no idea without seeing your macro.
Maybe if you post the macro I see something strange
--
Regards Ron de Bruinhttp://
www.rondebruin.nl/tips.htm
Unfortunately I can't send the database Ron because it's work-related/
sensitive. I wish it was not work-related so i can get this code
working properly for me.
Does it matter that I'm using Excel 2003? I have no idea why this
thing is not working because I simply pasted your code as is, and just
changed access file path, access name, table name, access column
names...etc.
I know I'm probably making a minor error somewhere, but since I'm
clueless about Macro..., what can I say.
Any other way you can assist will be greatly appreciated.
Thanks!- Hide quoted text -
- Show quoted text -
Here goes the codes, I hope it helps. I inserted those modules
manually - (Right-clicked on Project name - Insert - Module).
Thanks a great deal, Ron.
MODULE 1:
Sub TestGetData()
With Sheets("Criteria")
Sheets("Sheet1").Range("A7:H7").Value = .Cells(ActiveCell.Row,
1).Range("A1:H1").Value
GetDataFromAccess "R:\SM\Undecided\Page Me\index me v2.mdb",
"Sample Table", _
"Firm Name", "=", .Cells(ActiveCell.Row,
"B").Value, _
"Status", "=", .Cells(ActiveCell.Row,
"C").Value, _
"Game Firm Contact",
"=", .Cells(ActiveCell.Row, "D").Value, _
"Funds Impacted",
">=", .Cells(ActiveCell.Row, "E").Value, _
"Funds Impacted",
"<=", .Cells(ActiveCell.Row, "F").Value, _
"Start Date", ">=", .Cells(ActiveCell.Row,
"G").Value, _
"Start Date", "<=", .Cells(ActiveCell.Row,
"H").Value, _
Sheets("Sheet1").Range("A10"), "*", True,
True
End With
End Sub
Sub GoToCriteriaSheet()
Sheets("Criteria").Select
End Sub
MODULE 2:
'Look in the Examples module how you can call this 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
MODULE 3:
Option Explicit
Sub GetUniqueData()
'This example retrieves all unique records from the fields ShipVia,
ShipCountry and ShipCity
'The columns (K:O) are hidden and I use the data in the
Data>Validation cells
'This macro will run each time you open the workbook (workbook open
event)
GetUniqueDataFromAccessFields "R:\SM\Undecided\Page Me\index me
v2.mdb", "Sample Table", _
"Firm Name", _
"Status", _
"Game Firm Contact", _
"", _
"", _
"", _
"", _
Sheets("Criteria").Range("K1"), True
End Sub
Sub GetDateInfo()
'This example Retrieve the earliest and latest date in a date field
'This macro will run each time you open the workbook (workbook open
event)
GetMinMaxInfo "R:\SM\Undecided\Page Me\index me v2.mdb", "Sample
Table", _
"Start Date", _
Sheets("Criteria").Range("G8"), True
End Sub
Sub GetFundsImpactedInfo()
'This example Retrieve the lowest and highest Freight in a Freight
field
'This macro will run each time you open the workbook (workbook open
event)
GetMinMaxInfo "R:\SM\Undecided\Page Me\index me v2.mdb", "Sample
Table", _
"Firms Impacted", _
Sheets("Criteria").Range("E8"), True
End Sub
Public Sub GetUniqueDataFromAccessFields(MyDatabaseFilePathAndName As
String, MyTable As String, _
MyTableField1 As String, _
MyTableField2 As String, _
MyTableField3 As String, _
MyTableField4 As String, _
MyTableField5 As String, _
MyTableField6 As String, _
MyTableField7 As String, _
DestSheetRange As Range,
ClearRange As Boolean)
Dim MyConnection As String
Dim MySQL As String
Dim MyDatabase As Object
Dim I As Integer
Dim str1 As Variant
'If ClearRange = True clear all cells in column K:O
If ClearRange Then
Sheets(DestSheetRange.Parent.Name).Range(DestSheetRange.Address,
DestSheetRange.Offset(0, 4)).EntireColumn.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)
MySQL = ""
For I = LBound(str1) To UBound(str1)
If str1(I) <> "" Then
MySQL = "Select Distinct [" & str1(I) & "] 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
'Copy to K:M in the Criteria sheet (Columns are
hidden)
DestSheetRange.Offset(0, I).CopyFromRecordset
MyDatabase
Else
MsgBox "No records returned from : " & str1(I),
vbCritical
End If
MyDatabase.Close
Set MyDatabase = Nothing
End If
Next I
Exit Sub
SomethingWrong:
On Error GoTo 0
Set MyDatabase = Nothing
MsgBox "Error copying unique data", vbCritical, "Test Access data
to Excel"
End Sub
Public Sub GetMinMaxInfo(MyDatabaseFilePathAndName As String, MyTable
As String, _
MyTableField1 As String, _
DestSheetRange As Range, ClearRange As
Boolean)
Dim MyConnection As String
Dim MySQL As String
Dim MyDatabase As Object
'If ClearRange = True clear both cells first
If ClearRange Then
Sheets(DestSheetRange.Parent.Name).Range(DestSheetRange.Address,
DestSheetRange.Offset(0, 1).Address).ClearContents
'Create connection string
MyConnection = "Provider=Microsoft.Jet.OLEDB.4.0;"
MyConnection = MyConnection & "Data Source=" &
MyDatabaseFilePathAndName & ";"
MySQL = "Select Min([" & MyTableField1 & "]) AS Earliest, Max([" &
MyTableField1 & "]) AS Latest 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
DestSheetRange.CopyFromRecordset MyDatabase
Else
MsgBox "No records returned from : " & MyTableField1,
vbCritical
End If
MyDatabase.Close
Set MyDatabase = Nothing
Exit Sub
SomethingWrong:
On Error GoTo 0
Set MyDatabase = Nothing
MsgBox "Error copying unique data", vbCritical, "Test Access data
to Excel"
End Sub
THIS WORKBOOK:
Option Explicit
Private Sub Workbook_Open()
Sheets("Criteria").ScrollArea = "A11:H" & Rows.Count
'retrieves all unique records from the fields ShipVia, ShipCountry
and ShipCity
Call GetUniqueData
'Retrieve the earliest and latest date in a date field
Call GetDateInfo
'Retrieve the lowest and highest Freight in a Freight field
Call GetFundsImpactedInfo
End Sub
