VBA Function to talk to MS Access

[Guest]

I'm new to VBA programming, would appreciate some advice,

I have an Excel spreadsheet that needs a pulldown menu based on a SQL query
statement.

Would like to define a cell (or a named range) like this :
=(MyQueryTable(Worksheet1!$A$3))

where MyQueryTable is my new VBA function that does a very simple SQL query
call to a MS Access mdb file in the same directory as the excel sheet.

so, the SQL statement is something like this
"SELECT Position FROM PositionRate WHERE CompanyID = " & InputParameter & ";"

InputParameter is what i feed into this function (Worksheet!$A$3)

How would I do this ?

Appreciate your help.
Chad

 

[Ron de Bruin]

Hi ChadF

Maybe you like the example workbook with the Data validation cells in the
download on this page.

It read all unique values in the data validation list
http://www.rondebruin.nl/accessexcel.htm

 

[Guest]

Ok, I've followed the example listed in the website and produced the following
function based on that :

Option Explicit
Sub Import_Positions(InputVar As String, MyDatabaseFilePathName As String,
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
Debug.Print "I am in the subroutine, Input value is " & InputVar


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
& ";"


MySQL = "SELECT Position FROM PositionRate WHERE CompanyID = " & InputVar &
";"


' 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, 1).CopyFromRecordset MyDatabase
Else
MsgBox "No records returned from : PositionRate Table", 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

--------------------------------------------------------

The way I 'invoke' this function is through a named range variable in Excel
by doing Insert->Name->Define

let's say I give it a name "myRanges" and define it for what I think the sub
is returning (a range)... like so,

myRanges = (Worksheet1!$A$3, Worksheet1!$B$2, TRUE)

and then setting a validation pulldown menu based on this output.
Cell defined to be =myRanges

(Much of this function was cut-n-pasted from the example shown in
http://www.rondebruin.nl/accessexcel.htm)

When I did all the above, Excel came back to me with an error - source
evaluates to an error. When I tried looking at the error output screen in
the VBA editor windows, I didnt see anything to help.

I would appreciate any suggestions....

Thank you,
Chad

 

[Guest]

Whoops, meant to define the setting range call like this:

MyRanges = Import_Positions(Worksheet1!$A$3, Worksheet1!$B$2, TRUE)

where Worksheet1!$A$3 cell contains the string we want to query against
and Worksheet1!$B$2 contains the filenameandpath ...

 

[Ron de Bruin]

I use a dynamic range (list1 , list2 and list 3 ) in the example workbook
=OFFSET(Criteria!$K$1,0,0,COUNTA(Criteria!$K:$K),1)

See Debra's site
http://www.contextures.com/xlNames01.html#Dynamic

 

[Guest]

I use a dynamic range (list1 , list2 and list 3 ) in the example workbook
=OFFSET(Criteria!$K$1,0,0,COUNTA(Criteria!$K:$K),1)

See Debra's site
http://www.contextures.com/xlNames01.html#Dynamic

 

[Guest]

Hey Ron,

Just wanted to get back with you a little bit ... your example works very
well. I was able to craft a subroutine based on your macro that does queries
on the fly to a MS Access database.

Final code looks like this :

Public Sub GetRate()

Dim MyConnection As String
Dim MySQL As String
Dim MyDatabase As Object

Dim MyDatabaseFilePathAndName As String

MyDatabaseFilePathAndName = ThisWorkbook.Path & "\Statics.mdb"


'Create connection string
MyConnection = "Provider=Microsoft.Jet.OLEDB.4.0;"
MyConnection = MyConnection & "Data Source=" & _
MyDatabaseFilePathAndName & ";"

Sheets("Sheet1").Range("D410").ClearContents

'MySQL = "SELECT Position FROM PositionRate WHERE CompanyID = " &
InputVar & ";"

MySQL = "Select [Company] FROM Company"

' 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

'Return value of function (returns a range)
Sheets("Sheet1").Range("D4").CopyFromRecordset MyDatabase

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
'-----------------------------

I'm now making a series of subroutines / single-return functions that are
based on variations of the SQL logic outlined above.

Thanks so much )
Chad