An Access parameter query is a kind of interactive query that prompts you for criteria before the query is run. Parameter queries are useful when you need to ask the query different questions using different criteria each time you run it.
Now we all know you can pull data from Access into Excel using MS Query. The problem is that MS Query doesn't let you pull in Parameter queries. There may be a technical reason for this, but I like to think it's just Microsoft's way of keeping things interesting. After all, technical roadblocks are the spice of life.
If you've had enough spice, I'll show you a VBA workaround that will enable you to run an Access parameter query from Excel.
The Problem:
I've built this parameter query in Accesss. This particular query will ask the user for a Region and a Business Segment. This works fine in Access.
I've named this query MyParameterQuery.
The problem is when I try to connect to this query via MS Query in Excel, I don't see it in the list. It turns out that Parameter queries are not available in list of connectable objects.
Even if I try to get cocky, brute forcing MS Query to look at the query, I get the dreaded "Too Few Parameters" error.
The Solution:
My solution is to use a bit of VBA to pull the data based on parameters you enter directly into Excel.
The first step is to set up a spreadsheet like the one shown here. You'll notice that the needed parameters will be fed from Cells D3 and D4.
Once your spreadsheet is ready to go, switch over to VBA and enter this code into a standard module.
Note: You will need to add a reference to the Microsoft DAO XX Object Library (where XX represents the latest version you have) .
'Step 1: Declare your variables
Dim MyDatabase As DAO.Database
Dim MyQueryDef As DAO.QueryDef
Dim MyRecordset As DAO.Recordset
Dim i As Integer
'Step 2: Identify the database and query
Set MyDatabase = DBEngine.OpenDatabase _
("C:\Integration\IntegrationDatabase.accdb")
Set MyQueryDef = MyDatabase.QueryDefs("MyParameterQuery")
'Step 3: Define the Parameters
With MyQueryDef
.Parameters("[Enter Segment]") = Range("D3").Value
.Parameters("[Enter Region]") = Range("D4").Value
End With
'Step 4: Open the query
Set MyRecordset = MyQueryDef.OpenRecordset
'Step 5: Clear previous contents
Sheets("Main").Select
ActiveSheet.Range("A6:K10000").ClearContents
'Step 6: Copy the recordset to Excel
ActiveSheet.Range("A7").CopyFromRecordset MyRecordset
'Step 7: Add column heading names to the spreadsheet
For i = 1 To MyRecordset.Fields.Count
ActiveSheet.Cells(6, i).Value = MyRecordset.Fields(i - 1).Name
Next i
MsgBox "Your Query has been Run"
End Sub
After the code is ready, running it will make data magically appear based on your parameters!
Who needs MS Query?
This technique allows you to build some interesting reporting solutions with relatively little effort.
Thanks for this. My inability to make parameter queries work from Excel has been a major annoyance.
I only got this to work, though when I had changed the references to:
Microsoft Office 12.0 Access Database Engine Object Library, and
Microsoft Access 12.0 Object library (which should probably have been set before).
Now it works (mostly - sometimes fails on an
ODBC call, but I get the feeling that most of these Microsoft ODBC calls are not that robust, and anyway the Access database is linking to a series of tables in VFP format).
Hi Mike,
Yes good tip, I had some fun doing somthing not unlike this a while back, in the end the solution was a right hack!
http://www.blog.methodsinexcel.co.uk/2009/04/28/parameters-in-ado-getting-good-with-access-%E2%80%93-not/#comments
Thanks
Ross
In the book ‘Excel 2007 Advanced Report Development’, Timothy Zapawa talks about how to execute parameter queries in Excel without using VBA.
Some points of note include:
• Parameters are not really intended to be used with pivottable reports (but Zapawa provides a work around)
• Parameters can be used in an Excel query, although if the query cannot be displayed graphically then you’ll need to transform it into a stored procedure or view.
• Parameters can be integrated with web queries, but otly by creating an .isql file outside of Excel
There’s some supporting documents and videos posted at http://www.wiley.com/go/excelreporting/2007 that might be of interest – check out the files on offer under chapter 15: there’s a sample spreadsheet (which I can’t use on my PC because I don’t have the sample database loaded) and a video (which I cant view on my PC for some reason).
I personally find this book almost impossible to follow. Either I’m dumb, or the book is not written for beginners, or both.
Thanks for this great article. Parameter queries can be tricky but this is an easy to follow walk through. You should consider sharing your knowledge and expertise with the Office community on Facebook. Check it out at http://www.facebook.com/office
Cheers,
Andy
MSFT Office Outreach Team
Thanks for this, it helped me a lot with a project.
I have just one question, how can I close the connection with the DB without closing the Excel file?
Thanks
Roger
Roger: You could set the object variables to nothing.
Set MyRecordset = Nothing
Set MyQueryDef = Nothing
Set MyDatabase = Nothing
It would be simpler, I would think, to create the query without parameters and then add the parameters to the resulting derived table. I might be missing something here...
Colin,
I thought of the same thing... Why build the parameters in Access if your Reporting is going to take place in Excel...Easier to build the parameters in Excel
This is one of the more broken down explanations I have found. I am still some what of a beginner when it comes to macros, specially when it comes to db stuff. But I have a question. What if I have a whole range of parameters to query under one field? I would still like to use the wildcard.
Matt: You can set up your Access queries so that wildcards are part of the query.
For example, you can use this as the criteria:
LIKE "*" & [Enter Region & "*"
When you pass the parameter from Excel, the wild cards will automatically wrap your parameter.
The wildcards are not the issue. I do have that set up. Its querying the multiple parameters for the one field. I just mentioned the wildcard in case the solution was to combine the parameters.
I have an Access report that uses a parameter query. Is it possible to use a vba procedure to pass the parameter values and open the report without prompts?
Russ: Just use the code here and replace the Range parameters in Step 3 with the hard-coded values you need.
Hi i was wondering how much you would to set your blog design up on my internet site for me, because i really like the look of your internet site but i don't know how to set such a hot design.
Hey thanks for the code, it was really helpful with what I'm working on. I'm trying to do the same thing now, but the parameter query I want to run is a query of 2 other queries. It asks for 2 parameters just like the others, but it does not return the data I need, just the column headers. This query works in Access. Any suggestions? Thank you.
Hi there,
Thank you very much for the code provided, it was proven to be the best step forward I've had with these parameter queries from access to excel!
It's great that the data is being transfered over, but my solution goes a bit further than this. Due to the amount of rows that I'm sending over from Access I require this data to be put in a pivot table, instead of just manually transfered into Excel.
Any further help would be very much appreciated!
Lee: Can you not build your pivot table on top of the query results?
If you do, you can add a line of code to refresh the pivot table every time the query updates.
I am new to VBA, but I've followed this so far and i am producing an error and don't know where to go from here:
the error is at the .parameters..."item in the collection could not be found".
What have I done wrong? Thanks
Jessie: Sounds like you're pointing to a query or table that doesn't exist.
Probably in the line
MyDatabase.QueryDefs("MyParameterQuery")
Be sure to replace MyParameterQuery with your query name.
Thanks datapig,
but no, i did add my query name.
I believe that I am not connecting to my database. When I run a debug from the beginning it says (1) "set MyDatabase = nothing"
(2) "set myqueryDef = nothing"
(3) it halts at ".parameter = "nothing in collection"
'Step 2: Identify the database and query
Set MyDatabase = DBEngine.OpenDatabase _
("\\hous0205\bps_data2\25257\Reports\BPSInventoryReports.Mdb")
Set MyQueryDef = MyDatabase.QueryDefs("qryDailyReceivingLog - Duke - Revised")
1) Also my query prompts for a date between a certain date. I am not sure how to set step 3 correctly for the parameter.
Example: I need it to bring up data between [this date] and [that date] and it suppose to display the data for me.
2) Also, for the run Paramater query button, did you add the code to it's property? I don't know how to make that button work.
here is my code after I changed the information:
Sub RunParameterQuery()
'Step 1: Declare your variables
Dim MyDatabase As DAO.Database
Dim MyQueryDef As DAO.QueryDef
Dim MyRecordset As DAO.Recordset
Dim i As Integer
'Step 2: Identify the database and query
Set MyDatabase = DBEngine.OpenDatabase _
("\\hous0205\bps_data2\25257\Reports\BPSInventoryReports.Mdb")
Set MyQueryDef = MyDatabase.QueryDefs("qryDailyReceivingLog - Duke - Revised")
'Step 3: Define the Parameters
With MyQueryDef
.Parameters("[ENTER start DATE] and [Enter end date]") = Range("B7").Value
End With
'Step 4: Open the query
Set MyRecordset = MyQueryDef.OpenRecordset
'Step 5: Clear previous contents
Sheets("Main").Select
ActiveSheet.Range("A7:K10000").ClearContents
'Step 6: Copy the recordset to Excel
ActiveSheet.Range("A7").CopyFromRecordset MyRecordset
'Step 7: Add column heading names to the spreadsheet
For i = 1 To MyRecordset.Fields.Count
ActiveSheet.Cells(11, i).Value = MyRecordset.Fields(i - 1).Name
Next i
MsgBox "Your Query has been Run"
End Sub
Jessie: In your code, step three looks like
With MyQueryDef
.Parameters("[ENTER start DATE] and [Enter end date]") = Range("B7").Value
End With
You can't have start date and end date coming from the same cell. Try this.
With MyQueryDef
.Parameters("[ENTER start DATE]") = Range("B6").Value
.Parameters("[Enter end DATE]") = Range("B7").Value
End With
Make the start date come from cell B6 and end date come from cell B7,
As far as connecting to your databae, be sure you have access to the database.
Why attempt to update a pivot table from the data returned from the parameterize query, when a parameterize pivot table is really what you want?
thanks, dadapig. this is exactly what i needed. works perfectly!!!
Can you please tell me how to to this?
Note: You will need to add a reference to the Microsoft DAO XX Object Library (where XX represents the latest version you have) .
Is it another line of code?I keep getting complie error -user defined type not defined on this line: (MyDatabase As DAO.Database)
thanks
here is my code
Sub RunParameterQuery()
'Step 1: Declare your variables
Dim MyDatabase As DAO.Database
Dim MyQueryDef As DAO.QueryDef
Dim MyRecordset As DAO.Recordset
Dim i As Integer
'Step 2: Identify the database and query
Set MyDatabase = DBEngine.OpenDatabase _
("\\lm-file-dfs-01\central\Commkt\Production\LMG-Property\File-Cabinet\LM Equipment Breakdown\Middle Market Tracking\Database\Middle Market Tracking System_be")
Set MyQueryDef = MyDatabase.QueryDefs("SearchPades")
'Step 3: Define the Parameters
With MyQueryDef
.Parameters("[Enter Policy]") = Range("D3").Value
End With
'Step 4: Open the query
Set MyRecordset = MyQueryDef.OpenRecordset
'Step 5: Clear previous contents
Sheets("Main").Select
ActiveSheet.Range("A6:K10000").ClearContents
'Step 6: Copy the recordset to Excel
ActiveSheet.Range("A7").CopyFromRecordset MyRecordset
'Step 7: Add column heading names to the spreadsheet
For i = 1 To MyRecordset.Fields.Count
ActiveSheet.Cells(6, i).Value = MyRecordset.Fields(i - 1).Name
Next i
MsgBox "Your Query has been Run"
End Sub
Dave: In the Visual Basic Editor,
Go up to the toolbar and select Tools ->References.
This will bring up the references dialog box.
Go down the list and find the Microsoft DAO XX Object Library (where XX represents the latest version you have).
When you find it, place a check next to it then press OK.
This will added the needed reference.
thanks works great
Can you help with this one?
How would I plug this parameter into the format you provided? I am getting runtime 13 -mismatch
Like "*" & [] & "*" -error
.Parameters("[Enter Policy Number]") = Range("b3").Value
.Parameters("[Like "*" & [] & "*"]") = Range("b3").Value
here is what I am trying to do
Dave: Don't feed the LIKE operator through VBA. Build the like operator into your query.
For example, put this into the query criteria: Like "*" & [Param1] & "*"
Then just use .Parameters("[Param1]") Range("D3").Value
The LIKE operator will be applied on the Query side.
Just dropping a note to thank you. This code worked and completley saved a huge workaround for me.
I am stuck on a VB code I have that worked in 32 bit excel but does not work in 64 bit excel. I remove the soap client i was using at it is no longer supported and replaced it with MSXML
when I try to run the code I receive the following error
when I run the start client I get the attached error message
Compile Error: User Defined Type Not Defined
and then it goes to the Dim objHttp As MSXML.XMLHTTPRequest
(Note I also tried the MSXML.ServerXMLHTTPRequest and received the same error).
Any help would be greatly appreciated!
NOTE: I have tried adding the Microsoft XML 3.0, 4.0 and 6.0 reference library all resulting in the same error.
Below is my code:
Dim uname As String
Dim LogID As String
Dim isloggedin As Integer
Dim refreshrate As String
Dim isinitialized As Integer
Dim allowedMarkets As String
Dim alwdmktids() As String
Dim MktCells() As String
Dim MktColss() As String
Dim MktNames() As String
Dim MktTitles() As String
Dim MktCGreater() As String
Dim MktCLesser() As String
Dim MktLimitLess() As String
Dim MktLimitGreat() As String
Dim MktLimitEqual() As String
Dim MktColorString() As String
Dim MktColorLess() As String
Dim MktColorGreat() As String
Dim MktColorEqual() As String
Dim MktColorLess2() As String
Dim MktColorHeader() As String
Dim MktColorRowHeader() As String
Dim MktColorColHeader() As String
Dim MktColorColString() As String
Dim conditionsloaded As Integer
Dim clearcondition As String
Dim firsttime As Integer
Dim delsheetid As Integer
Dim delsheetcell As Integer
Dim ConExecting
Dim Cond_with_Market
Dim TheConditionString As String
Dim objHTTP As MSXML.XMLHTTPRequest
Public Const SND_ASYNC = &H1
Public Const SND_SYNC = &H0
Public Const SND_LOOP = &H8
Dim conditions_are_true As Integer
Dim Old_Mkt_Values() As String
Public Sub startclient()
On Error GoTo Handler
If isinitialized 1 Then
Set objHTTP = New MSXML.XMLHTTPRequest
objHTTP.Open “post”, "http://networksmarter.com/WebService.asmx?WSDL"
objHTTP.setRequestHeader “Content - Type”, ”text / xml”
Sheets(1).Cells(16, 6) = "Please login to get signals"
isinitialized = 1
End If
Exit Sub
Handler:
Sheets(1).Cells(16, 6) = "XML client not initialized with the server"
Exit Sub
End Sub
Public Sub stopclient()
Sheets(1).Cells(16, 6) = "Disconnected"
End Sub
Public Sub AttachedNodes()
If IsEmpty(ConExecting) Then
ReDim ConExecting(0) As Integer
ConExecting(UBound(ConExecting)) = 0
Else
ReDim Preserve ConExecting(UBound(ConExecting) + 1)
ConExecting(UBound(ConExecting)) = 0
End If
ReDim Preserve ConExecting(UBound(ConExecting) + 1)
ConExecting(UBound(ConExecting)) = 0
End Sub
Public Function login()
On Error GoTo Handler
If isinitialized = 1 Then
Dim str As String
str = objHTTP.LoginUserSite(Sheets(1).txtUsername.Text, Sheets(1).txtPassword.Text, "")
conditions_are_true = 0
If (InStr(str, "Done")) Then
Dim sarrtyn() As String
sarrtyn = Split(str, "~")
LogID = sarrtyn(1)
firsttime = 1
uname = Sheets(1).txtUsername.Text
Sheets(1).Cells(16, 6) = "Connected"
Sheets(1).ButtonLogin.Caption = "Disconnect"
Call objHTTP.checkuser(uname, LogID)
isloggedin = 1
CollectAllowedMarkets
'refreshrate = "00:00:04"
'Application.OnTime EarliestTime:=Now + TimeValue(refreshrate), Procedure:="RefreshValues"
oprprog = 0
Else
Sheets(1).Cells(16, 6) = str
End If
End If
Exit Function
Handler:
End Function
Public Function logout()
If isloggedin = 1 Then
Call objHTTP.LogoutUser(uname, LogID)
Sheets(1).ButtonLogin.Caption = "Connect"
Sheets(1).Cells(16, 6) = "Not Connected"
uname = ""
isloggedin = 0
Application.DisplayAlerts = False
For i = 2 To Sheets.Count
Sheets(2).Delete
Next
Application.DisplayAlerts = True
End If
End Function
Public Function CollectAllowedMarkets()
allowedMarkets = objHTTP.allowedMarkets(uname)
alwdmktids = Split(allowedMarkets, "~")
'Old_Mkt_Values = Split(allowedMarkets, "~")
MktCells = alwdmktids
MktCols = alwdmktids
MktNames = alwdmktids
MktTitles = alwdmktids
MktCGreater = alwdmktids
MktCLesser = alwdmktids
MktLimitLess = alwdmktids
MktLimitGreat = alwdmktids
MktLimitEqual = alwdmktids
MktColorLess = alwdmktids
MktColorLess2 = alwdmktids
MktColorGreat = alwdmktids
MktColorEqual = alwdmktids
MktColorString = alwdmktids
MktColorHeader = alwdmktids
MktColorRowHeader = alwdmktids
MktColorColHeader = alwdmktids
MktColorColString = alwdmktids
For i = 0 To UBound(alwdmktids)
Dim str As String
str = objHTTP.MarketColors(uname, alwdmktids(i))
Dim strarr() As String
strarr = Split(str, "~")
MktCells(i) = strarr(0)
MktCols(i) = strarr(1)
MktNames(i) = strarr(2)
MktTitles(i) = strarr(3)
MktCGreater(i) = strarr(4)
'MsgBox MktCGreater(i)
MktCLesser(i) = strarr(5)
'MsgBox MktCLesser(i)
MktColorGreat(i) = strarr(6)
MktColorLess(i) = strarr(7)
MktColorEqual(i) = strarr(8)
MktColorLess2(i) = strarr(9)
MktColorString(i) = strarr(10)
MktColorHeader(i) = strarr(11)
MktLimitGreat(i) = strarr(12)
MktLimitLess(i) = strarr(13)
MktLimitEqual(i) = strarr(14)
MktColorColHeader(i) = strarr(15)
MktColorRowHeader(i) = strarr(16)
MktColorColString(i) = strarr(17)
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = MktNames(i)
'ActiveSheet.Name = "Sheet" + CStr(i +
Sheets(i + 2).Cells(1, 1) = MktNames(i)
Sheets(i + 2).Cells(3, 1) = "Custom Fields"
Sheets(i + 2).Cells(3, 3) = MktTitles(i)
Dim colcordnates() As String
colcordnates = Split(MktColorHeader(i), "|")
Sheets(i + 2).Cells(3, 3).Interior.Color = RGB(CInt(colcordnates(0)), CInt(colcordnates(1)), CInt(colcordnates(2)))
With Sheets(i + 2).Range("C3:H3")
.Merge Across:=True
End With
Dim Formuid As Integer
Formuid = ((CInt(alwdmktids(i)) - 1) * 5)
For j = 1 To 5
str = objHTTP.GetFormula(uname, Formuid + j)
Dim avarSplit() As String
If (str "") Then
Dim thecol As String
thecol = ""
avarSplit = Split(str, "~")
For ii = 0 To UBound(avarSplit)
If ii Mod 2 = 0 Then
If InStr(avarSplit(ii), "c") = 0 Then
Dim rownum As Integer
rownum = CInt(avarSplit(ii)) \ CInt(MktCols(i))
rownum = rownum + 4
Dim colnum As Integer
colnum = CInt(avarSplit(ii)) Mod CInt(MktCols(i))
thecol = thecol & Chr(67 + colnum) & CStr(rownum)
Else
thecol = thecol & Mid(avarSplit(ii), 2, Len(avarSplit(ii)))
End If
Else
thecol = thecol & avarSplit(ii)
End If
Next ii
Sheets(i + 2).Cells(j + 3, 1) = "=" & thecol
End If
Next j
Next i
refreshrate = "00:00:02"
conditionsloaded = 0
RefreshValues
End Function
Public Sub CollectConditions()
For ii = 0 To UBound(alwdmktids)
Dim Formuids() As String
Dim formus As String
formus = objHTTP.GetCustomFormulaIDs(uname, alwdmktids(ii))
If formus "" Then
Formuids = Split(formus, "~")
Dim i, j, k As Integer
j = 0
For i = 0 To UBound(Formuids)
formus = objHTTP.GetCustomFormula(uname, Formuids(i))
Dim TempFOrmu() As String
TempFOrmu = Split(formus, "|")
Dim funparts() As String
funparts = Split(TempFOrmu(0), "~")
Dim tempcondition As String 'this condition would be installed
tempcondition = "=TestExec("
TheConditionString = MktNames(ii) & ": "
For k = 0 To UBound(funparts) 'left side
If InStr(funparts(k), "formu") = 0 Then 'the formula field is there then false
If k Mod (2) = 1 Then
tempcondition = tempcondition + funparts(k)
TheConditionString = TheConditionString + CStr(k)
Else
TheConditionString = TheConditionString + "cell" + funparts(k)
Dim rownum As Integer
rownum = CInt(funparts(k)) \ CInt(MktCols(ii))
rownum = rownum + 4
Dim colnum As Integer
colnum = CInt(funparts(k)) Mod CInt(MktCols(ii))
tempcondition = tempcondition + Chr(67 + colnum) + CStr(rownum)
End If
Else
Select Case funparts(k)
Case "formu1"
tempcondition = tempcondition + "A4"
TheConditionString = TheConditionString + "Custom 1"
Case "formu2"
tempcondition = tempcondition + "A5"
TheConditionString = TheConditionString + "Custom 2"
Case "formu3"
tempcondition = tempcondition + "A6"
TheConditionString = TheConditionString + "Custom 3"
Case "formu4"
tempcondition = tempcondition + "A7"
TheConditionString = TheConditionString + "Custom 4"
Case Else
tempcondition = tempcondition + "A8"
TheConditionString = TheConditionString + "Custom 5"
End Select
End If
Next 'Left side condition
If TempFOrmu(1) = "==" Then
tempcondition = tempcondition + ", ""="", "
TheConditionString = TheConditionString + " == "
Else
tempcondition = tempcondition + ", """ + TempFOrmu(1) + """, "
TheConditionString = TheConditionString + " " + TempFOrmu(1) + " "
End If 'Condition added
funparts = Split(TempFOrmu(2), "~")
For k = 0 To UBound(funparts) 'right side
If InStr(funparts(k), "formu") = 0 Then 'the formula field is there then false
If k Mod (2) = 1 Then
tempcondition = tempcondition + funparts(k)
TheConditionString = TheConditionString + funparts(k)
Else
TheConditionString = TheConditionString + "cell" + funparts(k)
rownum = CInt(funparts(k)) \ CInt(MktCols(ii))
rownum = rownum + 4
colnum = CInt(funparts(k)) Mod CInt(MktCols(ii))
tempcondition = tempcondition + Chr(67 + colnum) + CStr(rownum)
End If
Else
Select Case funparts(k)
Case "formu1"
tempcondition = tempcondition + "A4"
TheConditionString = TheConditionString + "Custom 1"
Case "formu2"
tempcondition = tempcondition + "A5"
TheConditionString = TheConditionString + "Custom 2"
Case "formu3"
tempcondition = tempcondition + "A6"
TheConditionString = TheConditionString + "Custom 3"
Case "formu4"
tempcondition = tempcondition + "A7"
TheConditionString = TheConditionString + "Custom 4"
Case Else
tempcondition = tempcondition + "A8"
TheConditionString = TheConditionString + "Custom 5"
End Select
End If
Next 'Right side condition
'check if the condition is already executing
If IsEmpty(ConExecting) Then
ReDim ConExecting(0) As Integer
ReDim Cond_with_Market(0) As String
ConExecting(UBound(ConExecting)) = 0
Cond_with_Market(UBound(Cond_with_Market)) = TheConditionString
Else
ReDim Preserve ConExecting(UBound(ConExecting) + 1)
ReDim Preserve Cond_with_Market(UBound(Cond_with_Market) + 1)
ConExecting(UBound(ConExecting)) = 0
Cond_with_Market(UBound(Cond_with_Market)) = TheConditionString
End If
tempcondition = tempcondition + ", """ + TempFOrmu(3) + """, """ + Formuids(i) + """," + CStr(4 + j) + ", " + CStr(ii + 2) + ", " + CStr(UBound(ConExecting)) + ", "" " + TempFOrmu(4) + " """ + ")"
'tempcondition = tempcondition + ", """ + TempFOrmu(3) + """, """ + Formuids(i) + """," + CStr(4 + j) + ", " + CStr(ii + 2) + ", " + CStr(UBound(ConExecting)) + ")"
Sheets(ii + 2).Cells(4 + j, 2) = tempcondition
tempcondition = ""
j = j + 1
Next i
End If
Next ii
Exit Sub
End Sub
Public Sub RefreshValues()
On Error GoTo Handler
MousePointer = vbNormal
If Sheets(1).ButtonLogin.Caption "Connect" Then
Dim colcordnates() As String
For i = 0 To UBound(alwdmktids)
Dim str As String
str = objHTTP.CollectInfoMarketNew(uname, alwdmktids(i), LogID)
'If Not Old_Mkt_Values(i) = str Then
'Old_Mkt_Values(i) = str
Dim avarSplit() As String
avarSplit = Split(str, "~")
Dim ii, j, k As Integer
j = 6
k = 0
Dim totrows As Integer
totrows = CInt(MktCells(i)) \ CInt(MktCols(i))
If UBound(avarSplit) + 1>= CInt(MktCells(i)) Then
For ii = 0 To totrows - 1
For j = 0 To CInt(MktCols(i)) - 1
If IsNumeric(avarSplit(k)) And avarSplit(k) "" Then
If CheckValueOp(Sheets(i + 2).Cells(ii + 4, j + 3), MktLimitLess(i), ">=") Then
colcordnates = Split(MktColorLess(i), "|")
Sheets(i + 2).Cells(ii + 4, j + 3).Interior.Color = RGB(CInt(colcordnates(0)), CInt(colcordnates(1)), CInt(colcordnates(2)))
End If
If CheckValueOp(Sheets(i + 2).Cells(ii + 4, j + 3), MktLimitEqual(i), ">=") Then
colcordnates = Split(MktColorEqual(i), "|")
Sheets(i + 2).Cells(ii + 4, j + 3).Interior.Color = RGB(CInt(colcordnates(0)), CInt(colcordnates(1)), CInt(colcordnates(2)))
End If
If CheckValueOp(Sheets(i + 2).Cells(ii + 4, j + 3), MktLimitGreat(i), ">=") Then
colcordnates = Split(MktColorGreat(i), "|")
Sheets(i + 2).Cells(ii + 4, j + 3).Interior.Color = RGB(CInt(colcordnates(0)), CInt(colcordnates(1)), CInt(colcordnates(2)))
End If
If CheckValueOp(Sheets(i + 2).Cells(ii + 4, j + 3), MktLimitLess(i), "<") Then
colcordnates = Split(MktColorLess2(i), "|")
Sheets(i + 2).Cells(ii + 4, j + 3).Interior.Color = RGB(CInt(colcordnates(0)), CInt(colcordnates(1)), CInt(colcordnates(2)))
End If
If Sheets(i + 2).Cells(ii + 4, j + 3) avarSplit(k) Then
If chkLess(Sheets(i + 2).Cells(ii + 4, j + 3), avarSplit(k)) Then
colcordnates = Split(MktCGreater(i), "|")
Sheets(i + 2).Cells(ii + 4, j + 3).Interior.Color = RGB(CInt(colcordnates(0)), CInt(colcordnates(1)), CInt(colcordnates(2)))
Else
colcordnates = Split(MktCLesser(i), "|")
Sheets(i + 2).Cells(ii + 4, j + 3).Interior.Color = RGB(CInt(colcordnates(0)), CInt(colcordnates(1)), CInt(colcordnates(2)))
End If
Sheets(i + 2).Cells(ii + 4, j + 3) = avarSplit(k)
End If
Else
If avarSplit(k) = "" Then
Sheets(i + 2).Cells(ii + 4, j + 3).Interior.Color = RGB(255, 255, 255)
Sheets(i + 2).Cells(ii + 4, j + 3) = avarSplit(k)
Else
colcordnates = Split(MktColorString(i), "|")
Sheets(i + 2).Cells(ii + 4, j + 3).Interior.Color = RGB(CInt(colcordnates(0)), CInt(colcordnates(1)), CInt(colcordnates(2)))
Sheets(i + 2).Cells(ii + 4, j + 3) = avarSplit(k)
End If
End If
If k Mod CInt(MktCols(i)) = 0 Then
colcordnates = Split(MktColorRowHeader(i), "|")
Sheets(i + 2).Cells(ii + 4, j + 3).Interior.Color = RGB(CInt(colcordnates(0)), CInt(colcordnates(1)), CInt(colcordnates(2)))
End If
If k <CInt(MktCols(i)) Then
colcordnates = Split(MktColorColHeader(i), "|")
Sheets(i + 2).Cells(ii + 4, j + 3).Interior.Color = RGB(CInt(colcordnates(0)), CInt(colcordnates(1)), CInt(colcordnates(2)))
End If
If avarSplit(k) = "" Then
colcordnates = Split(MktColorColString(i), "|")
Sheets(i + 2).Cells(ii + 4, j + 3).Interior.Color = RGB(CInt(colcordnates(0)), CInt(colcordnates(1)), CInt(colcordnates(2)))
End If
k = k + 1
Next j
Next ii
End If
'End If
Next i
If conditionsloaded = 1 Then
Application.OnTime EarliestTime:=Now + TimeValue(refreshrate), Procedure:="RefreshValues"
Else
If firsttime = 1 Then
CollectConditions
Application.OnTime EarliestTime:=Now + TimeValue(refreshrate), Procedure:="RefreshValues"
conditionsloaded = 1
Else
Sheets(delsheetid).Cells(delsheetcell, 2) = ""
Application.OnTime EarliestTime:=Now + TimeValue(refreshrate), Procedure:="RefreshValues"
conditionsloaded = 1
firsttime = 1
End If
End If
End If
Exit Sub
Handler:
Application.OnTime EarliestTime:=Now + TimeValue(refreshrate), Procedure:="RefreshValues"
Exit Sub
End Sub
Public Function TestExec(lftsde, cditon, rhtsde, opration, Formuid, ClearCellid, ClearSheetid, FormulaIndex, cond_text_sp)
TestExec = "Alert Not Triggered"
If Evaluate(lftsde & cditon & rhtsde) Then
If ConExecting(FormulaIndex) = 0 Then
If opration = "1" Then
Call objHTTP.SendAlert(uname, Cond_with_Market(FormulaIndex), Formuid)
TestExec = "Alert Triggered"
Else
If conditions_are_true = 0 Then
Call sndPlaySound32("C:\Program Files\Signal System Client\success.wav", SND_ASYNC + SND_LOOP)
End If
conditions_are_true = conditions_are_true + 1
If opration = "2" Then
Call objHTTP.Event_Log(uname, Cond_with_Market(FormulaIndex), "", "Play alarm")
Else
Call objHTTP.Event_Log(uname, Cond_with_Market(FormulaIndex), cond_text_sp, "Timer")
End If
TestExec = "Alert Triggered"
End If 'the condition whether operation is 1 or other
ConExecting(FormulaIndex) = 1
Else
If opration "1" Then
'Call sndPlaySound32("C:\Program Files\Signal System Client\success.wav", SND_ASYNC + SND_LOOP)
TestExec = "Alert Triggered"
End If
End If 'already executing operation or not
Else
If ConExecting(FormulaIndex) = 1 Then
ConExecting(FormulaIndex) = 0
conditions_are_true = conditions_are_true - 1
If conditions_are_true = 0 Then
Call sndPlaySound32("C:\Program Files\Signal System Client\none.wav", 1)
End If
End If
End If 'end of evaluation
End Function
Public Function CheckValueOp(leftvalue, rightvalue, compoperator) As Boolean
On Error GoTo Handler
If compoperator = "==" Then
If CDbl(leftvalue) = CDbl(rightvalue) Then
CheckValueOp = True
Else
CheckValueOp = False
End If
Exit Function
End If
If compoperator = "<" Then
If CDbl(leftvalue) =" Then
If CDbl(leftvalue)>= CDbl(rightvalue) Then
CheckValueOp = True
Else
CheckValueOp = False
End If
Exit Function
End If
Handler:
CheckValueOp = False
End Function
Public Function chkLess(frstvalu, scndvalu) As Boolean
On Error GoTo Handler
If CDbl(frstvalu) <CDbl(scndvalu) Then
chkLess = True
Else
chkLess = False
End If
Exit Function
Handler:
chkLess = False
End Function
Darrel: Wow...you've got alot going on here.
You'd have to give me a much simpler example than this.
Hello
Will this work using a runtime version of access?
I have it working on full verison of access but im having trouble with the runtime version.
thanks
Dave: Make sure you're referencing the database as an accdr.
Set MyDatabase = DBEngine.OpenDatabase _
("C:\Integration\IntegrationDatabase.accdr")
Thanks, you made my day. Works a treat.
I guess I am slow.. I get "Compile error: User-defined type not defined" on the first line "Dim MyDatabase As DAO.Database". And I don't really know what it means when you say "You will need to add a reference to the Microsoft DAO 12.0 [in my case] Object Library". Help & Thanks!
I am trying to run this code but get a 3343 run-time error message - unrecognizable database format? Help!
Trish: Make sure you're referencing the correct version of Access.
If you're using Access 2003, you'll ned to use this:
Set MyDatabase = DBEngine.OpenDatabase _
("C:\Integration\IntegrationDatabase.mdb")
Thanks for that but its Access 2007
Could it be something to do with References?
I am getting the following error:
'Run-time error '3112':
Record(s) cannot be read; no read permission on 'tblRequest'
'tblRequest' is one of the table in my query.
I am running Access and Office 2007. I have had to add a reference to: 'Microsoft Office 12.0 Access database engine object library' instead of 'Microsoft DAO 3.6 Object Library'
Is there anything else I should be doing?
Here is the top part of my query:
Sub RunParameterQuery()
'Step 1: Declare your variables
Dim MyDatabase As DAO.Database
Dim MyQueryDef As DAO.QueryDef
Dim MyRecordset As DAO.Recordset
Dim i As Integer
'Step 2: Identify the database and query
Set MyDatabase = DBEngine.OpenDatabase _
("\\lotus\data\Projects\Projects\Project Database\TaskManagerC.accde")
Set Db = OpenDatabase("\\lotus\data\Projects\Projects\Project Database\TaskManagerC.accde")
'Create a workspace with the correct login information
Set MyQueryDef = MyDatabase.QueryDefs("kbQryTaskTimeTotalsByRequest")
'Step 3: Define the Parameters
With MyQueryDef
.Parameters("[Enter Request]") = Range("C2").Value
End With
Hi,
I just found a funny solution to this, which allows to avoid coding, and remains sufficiently clean if the reporting is stable and not too complicated.
1. Create a XL sheet with your parameters (why not in the same workbook)
1bis. If you want to enter data in the main dashboard sheet, put a formula into the parameter sheet that points to the dashboard sheet
2. Go to access and make this sheet a linked table, with external data feature
3. Then you can use this table in the parameter fields or formulas with a subquery.
Works very nicely.
Regards,
Stevan