I'm having a problem getting a recordset to run from a query I created in an MS Access 2010 database. here is t he code I want to run:
Private Sub Command192_Click()
Dim recs As String
Dim param As Integer
Dim rs As Recordset
Set rs = CurrentDb.OpenRecordset("UnitRec_Qry", dbOpenDynaset)
With rs
.MoveLast
.MoveFirst
While Not .EOF
recs = recs & vbNewLine & !Spara & " - " & !Rec
.MoveNext
Wend
End With
MsgBox (recs)
End Sub
What this should output is a message box with a number of records from the query in a list. I do this so I can gather this and a number of other records into a text file for copying and pasting into a separate system. At the moment, I'm running this code so I can place it all into a string variable.
My problem is that I'm getting the dreaded "Too Few parameters expected 1" error.
The query works, I've saved it into the database and tested it and I get the expected results.
I tried running the recordset with SQL:
Set rs = CurrentDb.OpenRecordset("SELECT UnitRecommend_tbl.URecID, UnitRecommend_tbl.Spara," _
& " UnitRecommend_tbl.Rec, UnitRecommend_tbl.SvyID" _
& " FROM UnitRecommend_tbl" _
& " WHERE ((UnitRecommend_tbl.SvyID) = [Forms]![SurveyRegister_frm]![SurveyID])" _
& " ORDER BY UnitRecommend_tbl.Spara;", dbOpenDynaset)
I get the same error
I ran it again but removed the "WHERE" statement and the code ran just fine, but gave me every record in the table. Not what I wanted.
So, the fields are OK because the data runs. When I debug the text the parameter in the SQL does show up as the right parameter, in this case, the number 4 which is an integer.
So I'm at a loss here, I've searched through the other posts here and I have tried these possible solutions (unless I missed something).
I also tried using dbopensnapshot as well, still no joy. Wondering if I'm using the right code here now.
Any help would be great.
Cheers
A parameter like [Forms]![SurveyRegister_frm]![SurveyID] doesn't get evaluated automatically if you open a recordset in VBA.
Use this function:
Public Sub Eval_Params(QD As DAO.QueryDef)
On Error GoTo Eval_Params_Err
Dim par As DAO.Parameter
For Each par In QD.Parameters
' This is the key line: Eval "evaluates" the form field and gets the value
par.Value = Eval(par.Name)
Next par
Eval_Params_Exit:
On Error Resume Next
Exit Sub
Eval_Params_Err:
MsgBox Err.Description, vbExclamation, "Runtime-Error " & Err.Number & " in Eval_Params"
Resume Eval_Params_Exit
End Sub
with a QueryDef object like this:
Dim QD As QueryDef
Dim RS As Recordset
Set QD = DB.QueryDefs("UnitRec_Qry")
Call EVal_Params(QD)
Set RS = QD.OpenRecordset(dbOpenDynaset)
Alternatively, you can run it with SQL in the VBA code by moving the parameter outside of the SQL string:
Set rs = CurrentDb.OpenRecordset("SELECT UnitRecommend_tbl.URecID, UnitRecommend_tbl.Spara," _
& " UnitRecommend_tbl.Rec, UnitRecommend_tbl.SvyID" _
& " FROM UnitRecommend_tbl" _
& " WHERE ((UnitRecommend_tbl.SvyID) = " & [Forms]![SurveyRegister_frm]![SurveyID] & ")" & _
& " ORDER BY UnitRecommend_tbl.Spara;", dbOpenDynaset)
Related
I've been chasing my tail on this SQL query for a record set. If I comment the query out, I do not receive the type mismatch error, so I'm relatively confident it is in this query. The query also works just fine in the Query window in Access (sans the quotes for getting it into VBA). I cannot, for the life of me, figure out why I'm getting a Compile error: Type mismatch on this. It always goes to the last '&'. I think I posted all the relevant code below. Please help? I do intend to move this to a string variable in the end, but I want to get it working first.
edit: I can address the type mismatch by making the change noted below. However, now I get a 424 error. If I output this to a debug window and paste the output into an SQL query window in access, I get the result I expect, but VBA doesn't like it for some reason.
Dim rs As DAO.Recordset
Dim FileNumber As String
FileNumber = Me.txtFileNumber
Set rs = "SELECT tblParentRecord.FileNumber, tblChildRecord.CombinedName " _
& " FROM tblParentRecord INNER JOIN tblChildRecord ON tblParentRecord.FileNumber = tblChildRecord.FileNumber " _
Added: & " WHERE (((tblParentRecord.FileNumber)= " & """" & Me.FileNumber & """" & ")) "
Removed:& " WHERE (((tblParentRecord.FileNumber) LIKE'" & FileNumber & "*" & "'))')
Try,
Dim rs As Recordset
Dim db As Database
Dim FileNumber As String
Set db = CurrentDb
FileNumber = Me.txtFileNumber
strSql = "SELECT tblParentRecord.FileNumber, tblChildRecord.CombinedName " _
& " FROM tblParentRecord INNER JOIN tblChildRecord ON tblParentRecord.FileNumber = tblChildRecord.FileNumber " _
& " WHERE tblParentRecord.FileNumber Like '" & FileNumber & "' "
Set rs = db.OpenRecordset(strSql)
I have a table that I need to format for use in a manual upload process. The table is thousands of rows so I need to use a repeatable process to quickly fix the way the data is given to me into what it needs to be. I have zero ability to control the way the data comes to me today. But, I have to format it to use it due to a system limitation. My current table is 4 columns, I need to output it as 3 columns. I have to group up by field names: "brand" and "promotion". Field name: "skus" I need to take and merge them into one continuous string by a single "brand" and "promotion" combination.
There are duplicate "promotion" by a given brand since they are created at a product level. But, the system they go into need to be "brand", "promotion", "skus".
Not really sure if I need to use VBA to do some of this inside Access. Or I can do this in two different queries.
You will need to use a bit of VBA to do this. The VBA will need to loop a recordset of data from the table that is filtered on brand and promotion and build up the sku string. Something like this perhaps:
Function fJoinData(strBrand As String, strPromotion As String) As String
On Error GoTo E_Handle
Dim db As DAO.Database
Dim rsData As DAO.Recordset
Dim strSQL As String
Set db = DBEngine(0)(0)
strSQL = "SELECT skus FROM Table1 " _
& " WHERE Brand='" & strBrand & "' " _
& " AND Promotion='" & strPromotion & "';"
Set rsData = db.OpenRecordset(strSQL)
If Not (rsData.BOF And rsData.EOF) Then
Do
fJoinData = fJoinData & ", " & rsData!skus
rsData.MoveNext
Loop Until rsData.EOF
End If
If Left(fJoinData, 2) = ", " Then fJoinData = Mid(fJoinData, 3)
fExit:
On Error Resume Next
rsData.Close
Set rsData = Nothing
Set db = Nothing
Exit Function
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "fJoinData", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume fExit
End Function
Rather than inserting into a table, I would suggest just creating a query which can then be exported:
SELECT DISTINCT
T.Brand,
T.Promotion,
fJoinData(T.Brand,T.Promotion) AS skus
FROM Table1 AS T
Regards,
I have an Access 2016 database which use a form to select a time interval of 1 or more days.
A button let me to get the begin and end dates of the interval and do the follow 2 things:
a) build a query that, based on the dates, extracts a dataset from a table
b) open a pop-up form that show the dataset extracted by the query. There is no code on OpenForm event.
The magic is that everything works like a charm until I disable the Shift Bypass Key with the command
CurrentDb.Properties("AllowBypassKey") = False
After that the query still works well, but when the code try to open the form, 95% of the times, I get the error '2501 The OpenForm action was canceled', even if it worked well with Access 2013.
The code is quite simple, but after 3 days of hard work I still don't understand what is wrong. The only thing I got is that if I don't execute the CreateQueryDef instruction the error goes away and the form opens regoularly (even if it does not show the right dataset).
Therefore both the routine works alone, but they conflict if they run one after the other.
Below the code behind the button:
Private Sub Cmd_Meteo_Click()
On Error GoTo Err
Dim strFrmName As String
Dim datBegin As Date
Dim datEnd As Date
'Set the time interval
datBegin = Me.Txt_BeginTreatment 'Set the begin of the interval
datEnd = Me.Txt_Data 'Set tha end of the interval
'Build the query with meteo data
Call GetMetoData(Me.Txt_Region, Me.Cmb_MeteoStation, datBegin, datEnd, False)
'Set the form name
strFrmName = "Frm_DatiMeteoControllo"
'Check if the form is already open
If CurrentProject.AllForms(strFrmName).IsLoaded Then 'If the form is already open
DoCmd.Close acForm, strFrmName 'Close the form
End If
DoCmd.OpenForm strFrmName 'This line rise the 2501 error!
Exit_sub:
Exit Sub
Err:
MsgBox Err.Number & " " & Err.Description
Resume Exit_sub
End Sub
and the subroutine that build the query:
Public Sub GetMetoData(strRegion As String, intIdSM As Integer, datBegin As Date, datEnd As Date, bolTot As Boolean)
On Error GoTo Err
Dim db As DAO.Database
Dim strDbName As String
Dim qdf As DAO.QueryDef
Dim strSqlMeteo As String
Dim strLinkName As String
Dim strQryName As String
Set db = CurrentDb 'Set the db
strDbName = Application.CurrentProject.Name 'Get the db name
strTblName = GetMeteoTableName(strRegion, intIdSM) 'Get the name of the data table
strLinkName = "Tbl_DatiMeteo" 'Set the name of the linked table
strQryName = "TmpQry_DatiMeteoControllo" 'Set th name of the query
'SQL statement for the query
strSqlMeteo = "SELECT " & strLinkName & ".Data, ([" & strLinkName & "].[Precipitazione]) AS PrecTot, " & _
strLinkName & ".Tmin, " & strLinkName & ".Tmean, " & strLinkName & ".Tmax" & vbCrLf & _
"FROM " & strLinkName & vbCrLf & _
"WHERE (((" & strLinkName & ".Data) Between #" & Format(datBegin, "mm/dd/yyyy") & "# And #" & Format(datEnd, "mm/dd/yyyy") & "#));"
'Delete the previous query
If QueryEsiste(strDbName, strQryName) Then 'If the query already exist...
DoCmd.DeleteObject acQuery, strQryName 'delete the query.
End If
'Make the new query
Set qdf = db.CreateQueryDef(strQryName, strSqlMeteo)
Exit_sub:
qdf.Close
Set qdf = Nothing
db.Close
Set db = Nothing
Exit Sub
Err:
MsgBox Error$
Resume Exit_sub
End Sub
Does anyone has a hint or faced the same problem?
There should be no reason to delete the query:
If QueryEsiste(strDbName, strQryName) Then
' Modify the previous query.
Set qdf = db.QueryDef(strQryName)
qdf.SQL = strSqlMeteo
Else
' Create the new query.
Set qdf = db.CreateQueryDef(strQryName, strSqlMeteo)
End If
I already have the query that retrieves me the data in a correct way, this is my code.
Sub Main()
Dim sDBPath As String
sDBPath = "C:\Users\ges\Documents\ExploWR.mdb"
Call Query_Access_to_excel(sDBPath, "Explo1", "SELECT eipl.MOD_CODE, eipl.BOM_KEY, eipl.DIF, eipl.PART_NO, eipl.PART_DESC, eipl.QTY_PER_CAR, eipl.INTERIOR_COLOUR, eipl.EXTERIOR_COLOUR, eipl.SOURCE_CODE, eipl.SHOP_CLASS," & _
" eipl.PART_CLASS, eipl.PROCESS_CODE, eipl.OPERATION_NO, eipl.DESIGN_NOTE_NO, eipl.WIP, eipl.PART_ID_CODE, eipl.ADOPT_DATE_Y2K,eipl.ABOLISH_DATE_Y2K, ipo_Modelos.EIM, ipo_Modelos.DEST, ipo_Modelos.MY " & _
" FROM eipl, explo, ipo_Modelos" & _
" WHERE explo.MOD_CODE = eipl.MOD_CODE And explo.MY = ipo_Modelos.MY" & _
" And explo.PLANT = ipo_Modelos.PLANT And eipl.ADOPT_DATE_Y2K <= explo.ADOP " & _
" And explo.DEST = ipo_Modelos.DEST And explo.EIM = ipo_Modelos.EIM")
End Sub
Sub Query_Access_to_excel(sBd As String, sHoja As String, sSQL As String)
On Error GoTo error_handler
Dim rs As ADODB.Recordset
Dim conn As String
Dim Range_Destino As Range
Set Range_Destino = ActiveWorkbook.Sheets(sHoja).Cells(6, 1)
conn = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source= " & sBd & ";"
Set rs = New ADODB.Recordset
Call rs.Open(sSQL, conn, adOpenForwardOnly, adLockReadOnly)
If Not rs.EOF Then
Range_Destino.Offset(1, 0).CopyFromRecordset rs
DoEvents
MsgBox "Import Complete", vbInformation
Else
MsgBox "No registers to import", vbInformation
End If
If Not rs Is Nothing Then
If rs.State = adStateOpen Then
rs.Close
End If
Set rs = Nothing
End If
If Not Range_Destino Is Nothing Then
Set Range_Destino = Nothing
End If
Exit Sub
error_handler:
MsgBox Err.Description, vbCritical
End Sub
What I want to do is to correctly place the data in the cells, something like this.
And what I have is something like this. I want to place the data in the correct cells, I'm talking about the last 3 fields to be properly placed in the columns like the first image. I have no idea how to do this without affecting my query.
So as far as exporting the data into excel you have several options:
SQL do command:
https://msdn.microsoft.com/en-us/library/office/ff844793.aspx
Same command but in VBA:
Using Excel VBA to export data to MS Access table
You could iterate through the table and create an array then print that array into a spreadsheet
Once you have the data in excel you're just looking at formatting -- adding some filters, changing the text align, ect.. you can use the "Record Macro" function to perform those tasks and clean the code.
So I guess for clarification - what do you mean 'affecting your query?'
I have a composite primary key on 2 columns in the table I am INSERTing into. I come from working with SQL Server, and I know that if I attempted to insert a duplicate key value into a PK table, it would throw an error.
My problem is, my code is not throwing this kind of error. Can you look at it and see if it's a problem with the code? Or does Access not throw errors for this kind of violation?
[Edit]
I guess I'm looking for a way to just acknowledge that duplicate records are attempted to be inserted. I want the current functionality to remain (dups are tossed; valid records are inserted). I don't want the entire INSERT to get rolled back.
My code is below.
Function InsertData(Ignore As String)
' define file path of CSV to be imported
Dim CurrentDate As String
Dim CurrentYear As String
CurrentDate = Format(Date, "yyyymmdd")
CurrentYear = Format(Date, "yyyy")
Dim Exfile As String
Exfile = iPath + "\" + CurrentYear + "\" + "FileName" + CurrentDate + ".txt"
'this calls a saved import routine
DoCmd.RunSavedImportExport "tbl_TEMP"
'merge data with that already existing in tbl_Perm.
'the clustered PK on product_ID and As_of_Date prevents dup insertion
Dim dbs As Database
Dim errLoop As Error
Set dbs = OpenDatabase(iPath + "\ExDatabase.mdb")
dbs.Execute " INSERT INTO tbl_Perm (Col1,Col2,Date_Created) " _
& "SELECT ColA + ColB, ColC, Format$(Now(),'Short Date')" _
& "FROM tbl_TEMP;"
' Trap for errors, checking the Errors collection if necessary.
On Error GoTo Err_Execute
'delete temp table
dbs.Execute "DROP TABLE tbl_TEMP;"
dbs.Close
Err_Execute:
' Notify user of any errors that result from
' executing the query.
If DBEngine.Errors.Count > 0 Then
For Each errLoop In DBEngine.Errors
MsgBox "Error number: " & errLoop.Number & vbCr & _
errLoop.Description
Next errLoop
End If
Resume Next
End Function
From the Microsoft DAO Doc (here):
In a Microsoft Access workspace, if you provide a syntactically
correct SQL statement and have the appropriate permissions, the
Execute method won't fail — even if not a single row can be modified
or deleted. Therefore, always use the dbFailOnError option when using
the Execute method to run an update or delete query. This option
generates a run-time error and rolls back all successful changes if
any of the records affected are locked and can't be updated or
deleted.
So add the dbFailOnError option to your call.
If you want to allow the INSERT to proceed and determine whether any duplicates were rejected then you could do something like this
Dim cdb As DAO.Database, qdf As DAO.QueryDef, rst As DAO.Recordset
Dim sqlSelect As String, sourceRecords As Long
Set cdb = CurrentDb
sqlSelect = _
"SELECT ColA + ColB, ColC, Format$(Now(),'Short Date') " & _
"FROM tbl_TEMP"
Set rst = cdb.OpenRecordset("SELECT COUNT(*) AS n FROM (" & sqlSelect & ")", dbOpenSnapshot)
sourceRecords = rst!n
rst.Close
Set rst = Nothing
Set qdf = cdb.CreateQueryDef("", _
"INSERT INTO tbl_Perm (Col1,Col2,Date_Created) " & sqlSelect)
qdf.Execute
If qdf.RecordsAffected < sourceRecords Then
Debug.Print sourceRecords - qdf.RecordsAffected & " record(s) not inserted"
End If
Set qdf = Nothing
Set cdb = Nothing
The line
On Error GoTo Err_Execute
is after you execute your SQL statement. The Err_Execute block will - in this case - be called every time because there is not statement like Exit Function before the label. I am not sure what happens to the errors if you close the connection before evaluating the error collection.