I'm start to do programming in Access, and I really need help!!
My objective is to create a module that is run in "tbCustoProjeto" table and rewrite the field "Valor HH" values based on Dlookup. I found some solution (by azurous) who I think will solve this, but when I run the code, is returned
"object-required-error".
Sub redefineHH()
Dim objRecordset As ADODB.Recordset
Set objRecordset = New ADODB.Recordset
Dim i As Integer
Dim value As Variant
Dim HHTotal As Double
Set HHTotal = DLookup("[CustoTotalNivel]", "tbNivelNome2", "nUsuario='" & tbCustoProjeto!NumUsuario & "'" & "AND Numeric<=" & tbCustoProjeto!DataNumero)
'initated recordset obejct
objRecordset.ActiveConnection = CurrentProject.Connection
Call objRecordset.Open("tbCustoProjeto", , , adLockBatchOptimistic)
'find the target record
While objRecordset.EOF = False
'If objRecordset.Fields.Item(13).value > 0 Then
objRecordset.Fields.Item(13).value = HHTotal
objRecordset.UpdateBatch
'exit loop
'objRecordset.MoveLast
objRecordset.MoveNext
'End If
Wend
MsgBox ("Pesquisa Finalizada")
End Sub
Print of tbCustoProjeto
Print of tbNivelNome2
Please, someone can tell me where is the error? I don't know what to do.
Cannot reference a table directly like that for dynamic parameter. DLookup should pull dynamic criteria from recordset and within loop. Don't use apostrophe delimiters for number type field parameter.
Remove unnecessary concatenation.
Sub redefineHH()
Dim objRecordset As ADODB.Recordset
Set objRecordset = New ADODB.Recordset
objRecordset.Open "tbCustoProjeto", CurrentProject.Connection, , adLockBatchOptimistic
While objRecordset.EOF = False
objRecordset.Fields.Item(13) = DLookup("[CustoTotalNivel]", "tbNivelNome2", _
"nUsuario=" & objRecordset!NumUsuario & " AND Numeric <=" & objRecordset!DataNumero)
objRecordset.UpdateBatch
objRecordset.MoveNext
Wend
MsgBox ("Pesquisa Finalizada")
End Sub
Related
I have some vba code that 'attempts' to loop through an array of DAO recordsets. When running the loop, I get a runtime error 'Oject required' at rst.MoveFirst. It seems that rst is not properly initialized but I'm not sure how to fix it. Maybe looping through an array of recordsets isnt even possible in this way I have never tried it before. The code runs from a custom class module. There is a bunch more code in the module but most of the important stuff I post below. A couple things I tried:
Set rst to a new recordset instance manually:
Set rst = New DAO.Recordset
Declaring the array outside the loop:
Set recordsets = Array(rstRechenwerte, rstZwischenwerte, rstZutaten)
' Loop through each recordset and insert data into Excel file
For Each rst In recordsets
Setting rst to an open recordset right before rst.MoveFirst:
For Each rst In Array(rstRechenwerte, rstZwischenwerte, rstZutaten)
Set rst = rst.OpenRecordset()
rst.MoveFirst
The three recordsets in the array are properly initialized, set and are not Nothing. I had previously written the code for each of the three recordsets seperately and it works that way. I am aware that I need to change the variable name XLColumn, but thats not really an issue atm. Its probably something bassic but I couldn't figure it out for a while now so I thought I'd just ask.
I am using the following libraries for which references are properly set:
Visual Basic for Applications
Microsoft Access 16.0 Object Library
OLE Automation
Microsoft Office 16.0 Access database engine Object
Library
Microsoft Excel 16.0 Object Library
Microsoft Office 16.0 Object Library
My version of Access:
Microsoft® Access® für Microsoft 365 MSO (Version 2301 Build 16.0.16026.20002) 32 Bit
The code:
Option Compare Database
Option Explicit
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rsRes As DAO.Recordset 'rs of temp table (Output)
Dim rsZwi As DAO.Recordset 'rs of temp table (Zwischenwerte)
Dim rsRec As DAO.Recordset 'rs clone of subform Rechenwerte
Dim Recordset As Recordset
Dim rstRechenwerte As DAO.Recordset 'rs of tblRechenwerte
Dim rstZwischenwerte As DAO.Recordset 'rs of tblZwischenwerte
Dim rstZutaten As DAO.Recordset 'rs of tblZutaten
Dim RezeptID As Integer 'Current form active RezeptID
Dim RechengruppeID As Integer 'Current Form active RechengruppeID
Dim xlColumn As String 'Excel Column of Zutaten
Dim xlLastRow As Long 'Excel last row number after insertion
Dim xlColumn2 As String 'Excel Column one to the right of Zutaten
Dim k As Integer
Dim Export As Boolean 'Export the Excel File
Dim ExclExportPath As String 'Export location as string
Sub Calculate()
'***************************************************************************
'Purpose: Calculate a recipe based on Rechenwerte,
'save them temporarily and display them on a form.
'Inputs: None
'***************************************************************************
'***********************************************************************
' Preparations
'***********************************************************************
'Disable user input
Call mdlMiscFunctions.DisableKeyboardMouse(True)
'Clear temporary data tables for Results and Zwischenwerte
If Not rsRes.EOF Then Call ClearTableOnClose("tblTempResults")
If Not rsZwi.EOF Then Call ClearTableOnClose("tblTempZwischenwerte")
'Prevent prompt to save changes to excel
xlApp.DisplayAlerts = False
xlApp.Visible = False
'***********************************************************************
' Insert Data into Excel File
'***********************************************************************
Dim rst As DAO.Recordset
Dim xlCell As String
Dim xlFormula As String
Dim xlColumn As String
' Loop through each recordset and insert data into Excel file
For Each rst In Array(rstRechenwerte, rstZwischenwerte, rstZutaten)
rst.MoveFirst
If Not rst.EOF Then
Do Until rst.EOF
xlCell = rst!xlCell
xlSheet.Range(xlCell).Value = rst.Fields(1)
If rst.Fields.Count > 2 Then
xlFormula = rst!xlFormula
xlSheet.Range(xlCell).Offset(0, 1).Formula = xlFormula
xlSheet.Range(xlCell).Offset(0, 1).Value = xlSheet.Range(xlCell).Offset(0, 1).Value
Else
xlSheet.Range(xlCell).Offset(0, 1).Value = rst.Fields(2)
End If
rst.MoveNext
Loop
Else
Select Case rst.Name
Case "rstRechenwerte"
MsgBox "Error: Keine Rechenwerte vorhanden!", vbCritical
Case "rstZwischenwerte"
MsgBox "Error: Keine Zwischenwerte vorhanden!", vbCritical
Case "rstZutaten"
MsgBox "Error: Keine Zutaten vorhanden!", vbCritical
End Select
End If
Next rst
Class initialization is the following:
Private Sub Class_Initialize()
'***************************************************************************
'Purpose: Sub for initializing class variables
'Inputs: None
'***************************************************************************
'Values for variables 1 (Neccesary for recordsets)
RezeptID = Forms.frmCalcBatch.RezeptID 'RezeptID on current form
RechengruppeID = Forms.frmCalcBatch.RechengruppeID 'Rechengruppe on Current Form
'Initialize Objects
Set xlApp = CreateObject("Excel.Application")
Set xlWB = xlApp.Workbooks.Add
Set xlSheet = xlWB.Sheets("Tabelle1") 'Set xlSheet to the first sheet in the workbook
Set rsRes = CurrentDb.OpenRecordset("tblTempResults", dbOpenDynaset)
Set rsZwi = CurrentDb.OpenRecordset("tblTempZwischenwerte", dbOpenDynaset)
Set rsRec = Forms.frmCalcBatch.frmSubRechenwerteBox.Form.Recordset.Clone 'rs clone of Rechenwerte subform
Set rstRechenwerte = CurrentDb.OpenRecordset("SELECT Rechenwert, WertBezeichnung, XLCell FROM tblRechenwerte WHERE RechengruppeID = " & RechengruppeID)
Set rstZwischenwerte = CurrentDb.OpenRecordset("SELECT ZWBezeichnung, XLFormula, XLCell FROM tblZwischenwerte WHERE RezeptID = " & RezeptID)
Set rstZutaten = CurrentDb.OpenRecordset("SELECT Zutat, XLFormula, XLCell FROM tblZutaten WHERE RezeptID = " & RezeptID)
'Values for Variables 2 (recordsets neccesary for variables)
xlColumn2 = Split(rstZutaten!xlCell, "1")(0) 'extract excel column denominator for Zutaten
xlColumn2 = Chr(Asc(xlColumn2) + 1) 'Move one column to the right using Asc (A->B etc.)
'Settings:
If Forms.frmCalcBatch.cbExport = True Then
Export = True
ExclExportPath = GetExportPath
Else
Export = False
ExclExportPath = ""
End If
End Sub
You cannot New up a DAO.Recordset, the code will not even compile.
To loop through an array of recordsets, each recordset must initialized before it is added to the array.
For example:
Dim r1 As DAO.Recordset, r2 As DAO.Recordset, r3 As DAO.Recordset
Set r1 = CurrentDb().OpenRecordset("YourTableOrQueryName")
Set r2 = CurrentDb().OpenRecordset("YourTableOrQueryName")
Set r3 = CurrentDb().OpenRecordset("YourTableOrQueryName")
Put the recordsets now in the array.
Dim arr As Variant
arr = Array(r1, r2, r3)
To loop, you need to use a For loop and either access the recordset from the array directly, or declare another recordset variable to hold the iterating recordset.
Through an iterator variable:
Dim r As DAO.Recordset, i As Integer
For i = LBound(arr) To UBound(arr)
Set r = arr(i)
If Not r.EOF Then
r.MoveFirst
Debug.Print r.RecordCount
End If
Next i
Access it directly from the array:
For i = LBound(arr) To UBound(arr)
If Not arr(i).EOF Then
arr(i).MoveFirst
Debug.Print arr(i).RecordCount
End If
Next i
Though I fail to see why you need to have 3 recordsets in memory at the same time. Personally, I would offload the work that needs to be done in the loop to a separate function and pass the recordset as parameter. The function itself would return a success/failed status, so you can take the appropriate action based on the result.
Another approach would be to store the source names in the array, and create the recordset on demand during the loop.
Hope this helps.
I want to be able to execute a SQL Server stored procedure from MS Access VBA, in such a way that I can read (1) all the resulting result sets, not just the first one; and (2) any messages produced by PRINT statements or similar.
I have a test stored procedure with one input parameter, which produces 3 distinct result sets and about 90 messages. It calls several sub-stored procedures, I can EXEC it perfectly well from SSMS, but it isn’t clear (to me) how best to do it from Access VBA. I have tried the following so far:
DAO. Using SQL pass-through queries, I can get a lot of what I want in DAO, though it is a little clunky. It returns the first of the 3 result sets as a recordset, and by using the LogMessages attribute I can get a table (“Admin – NN”) containing the emitted messages.
ADO. Using Connection and Command objects, I can obtain a single recordset representing the first result set from the stored procedure. However, I can’t seem to persuade it to produce anything but a forward-only recordset. Regarding messages, at one point, all of them (at least, the first 127 of the approx. 150 I expected) were going into the connection’s Errors collection (!), but when I cut the number down to about 90, none of them appeared anywhere at all that I could find.
What I really want, as I said at first, is the output from all result sets, plus the messages. Is this possible?
Here is a listing of the routine I am currently using for executing a stored procedure :
Function ExecuteStoredProcedureADO(SPName As String, Connect As String, ReturnsRecords As Boolean, _
ParamArray Params() As Variant) As ADODB.Recordset
' v1.0 2018/06/26
' execute stored procedure SPName on a SQL Server database specified by the string in Connect
Dim strErr As String
Dim i As Integer
Dim lngRecsAffected As Long
Dim cnn As ADODB.Connection
Dim cmd As ADODB.Command
Dim errCurr As ADODB.Error
Dim rst As ADODB.Recordset
On Error GoTo Catch
Set ExecuteStoredProcedureADO = Nothing
Set cnn = New ADODB.Connection
cnn.Errors.Clear
cnn.mode = adModeRead
cnn.CommandTimeout = 300
cnn.Open Connect
Set cmd = New ADODB.Command
With cmd
.ActiveConnection = cnn
.CommandText = SPName
.CommandType = adCmdStoredProc
For i = 0 To UBound(Params) Step 4
.Parameters.Append .CreateParameter(Params(i), Params(i + 1), adParamInput, Params(i + 2), Params(i + 3))
Next i
Set rst = New ADODB.Recordset
rst.CursorType = adOpenStatic
If ReturnsRecords Then
'''Set rst = .Execute(lngRecsAffected)
rst.Open cmd, , adOpenStatic, adLockReadOnly
Else
Set rst = .Execute(, , adExecuteNoRecords)
End If
End With
If ReturnsRecords Then Set ExecuteStoredProcedureADO = rst
Final:
On Error Resume Next
If Len(strErr) > 0 Then Call AppendMsg(strErr)
Set rst = Nothing
Set cmd = Nothing
Exit Function
Catch:
If cnn.Errors.Count > 0 Then
With cnn
For Each errCurr In cnn.Errors
strErr = strErr & "Error " & errCurr.Number & ": " & errCurr.Description _
& " (" & errCurr.Source & ")" & vbCrLf
Next errCurr
strErr = Left(strErr, Len(strErr) - 2) ' truncate final CRLF
End With
Else
strErr = "Error " & Err.Number & ": " & Err.Description & " (" & Err.Source & ")"
End If
MsgBox strErr, vbOKOnly, gtitle
Resume Final
End Function
Addendum: Regarding the multiple result sets, I am hoping that http://msdn.microsoft.com/en-us/library/ms677569%28VS.85%29.aspx
will be of some help.
To shamelessly piggy-back off of #Erik, you want to create a new class that will handle your processing. Something like cProcedureHandler. Within this class, you need to declare an ADODB.Connection object using the WithEvents keyword:
Dim WithEvents cn As ADODB.Connection
Then, you need to write a InfoMessage event handler that will take care of the multiple print statements. Information about the InfoMessage event can be found here, and using the connection's Errors collection can be found here. So you'll end up with something like this:
Private Sub cn_InfoMessage(ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection)
Dim err As ADODB.Error
Debug.Print cn.Errors.Count & " errors"
For Each err In cn.Errors
' handle each error/message the way you need to.
Debug.Print err.Description
Next err
End Sub
Since you've taken care of the code to handle multiple messages, now you just need to handle the multiple recordsets, which is explained pretty well in the link you provided. One thing I noticed was that the example link used rs is nothing as the check for when there were no more recordsets, which didn't work for me. I had to use the rs State property. So I ended up with this:
Public Sub testProcedure()
Dim cmd As ADODB.Command
Dim rs As ADODB.Recordset
Dim recordSetIndex As Integer
Set cn = modData.getConnection
Set cmd = New ADODB.Command
cmd.ActiveConnection = cn
cmd.CommandType = adCmdStoredProc
cmd.CommandText = "dbo.sp_foo"
Set rs = cmd.Execute
recordSetIndex = 1
Do Until rs.State = ObjectStateEnum.adStateClosed
Debug.Print "contents of rs #" & recordIndex
Do Until rs.EOF
Debug.Print rs.Fields(0) & rs.Fields(1)
rs.MoveNext
Loop
Set rs = rs.NextRecordset
recordSetIndex = recordIndex + 1
Loop
cn.Close
Set rs = Nothing
Set cn = Nothing
Set cmd = Nothing
End Sub
Then, when you're ready to run your SP from VBA, just do something like this:
set obj = new cProcedureHandler
obj.testFooProcedure
Another thing (you probably have already done this): Make sure your actual stored procedure in SQL Server sets nocount on.
I am creating a simple spreadsheet which takes an array of IDs from worksheet "input", queries an Oracle database asking for only the records which match the IDs in the array and outputs the results to worksheet "output".
So far, my VBA will work if my array only contains a single ID (by specifying a single cell range), and everything completes with the desired output from the Oracle database appearing in worksheet "output". Good times.
The problem I am having now is that I want to specify a range of IDs (anything up to around 5000) in worksheet "input" to include in my array and pass that array to the Oracle database to return data for each ID it finds (I am not expecting all IDs to exist). Whenever I try this I seem to get "Error 13 Type Mismatch" errors... Bad times.
My VBA code is:
Dim OracleConnection As ADODB.Connection
Dim MosaicRecordSet As ADODB.RecordSet
Dim SQLQuery As String
Dim DBConnect As String
Dim count As String
Dim strbody As String
Dim Exclude As String
Dim i As Integer
Dim Rec As RecordSet
Dim InputIDs As Variant
Set OracleConnection = New ADODB.Connection
DBConnect = "Provider=msdaora;Data Source=MOSREP;User ID=***;Password=***;"
OracleConnection.Open DBConnect
' Clear Output Sheet Down
Sheets("Output").Select
Range("A2:F10000").Clear
' Set Input Range
Sheets("Input").Columns("A:A").NumberFormat = "0"
InputIDs = Sheets("Input").Range("A2:A10").Value
' SQL Query
SQLQuery = "select DMP.PERSON_ID, DMP.FULL_NAME, DMP.DATE_OF_BIRTH, DMA.ADDRESS, DMA.ADDRESS_TYPE, DMA.IS_DISPLAY_ADDRESS " & _
"from DM_PERSONS DMP " & _
"join DM_ADDRESSES DMA " & _
"on DMA.PERSON_ID=DMP.PERSON_ID " & _
"where DMP.PERSON_ID in (" & InputIDs & ")"
Set MosaicRecordSet = OracleConnection.Execute(SQLQuery)
Sheets("Output").Range("A2").CopyFromRecordset MosaicRecordSet
' Change DOB Format
Sheets("Output").Columns("C:C").NumberFormat = "dd/mm/yyyy"
' Set Left Alignment
Sheets("Output").Columns("A:Z").HorizontalAlignment = xlHAlignLeft
Range("A1").Select
OracleConnection.Close
Set MosaicRecordSet = Nothing
Set OracleConnection = Nothing
ActiveWorkbook.Save
Can anyone shed light on what I am missing? I have attempted to resolve the Type Mismatch issue by setting the 'numberformat' on the column in worksheet "input" to "0" but that didn't help. I also thought that I might have to have a loop to iterate through each record, but I haven't got to that stage yet because of this Type Mismatch thing...
Thank you everyone for your help in advance!
Regards
Matt
The ID's need to be comma delimited
InputIDs = getIDs( Sheets("Input").Range("A2:A10") )
Function getIDs(rng As Range)
Dim c As Range
Dim s As String
For Each c In rng
s = s & c.Value & ","
Next
getIDs = Left(s, Len(s) - 1)
End Function
I have a table with a field containing multi-valuable as shown below:
In the form, I want to let the user enter a NCR_Num in the textbox then using VBA to do some input validation then add it to the "text_Pool" as shown below:
This Text_Pool has the NCR_Num as the control source so if there is a NCR number added or deleted from it, it will automatically update the NCR_Num field.
I am not quite sure how to handle this data type.
In VBA, I cannot obtain the value from the Text_Pool because I think I need to treat it as an array or recordset
Below is an example of me trying the recordset attempt but obviously I am quite confused on what I am doing:
Public Function get_NCR_Num(SCAR_Num As Integer) As Integer()
Dim dbsMain As DAO.Database
Dim rstMain As DAO.Recordset
Dim childRS As Recordset
Dim sSearchField, sCriteria As String
Set dbsMain = CurrentDb
Set rstMain = dbsMain.OpenRecordset("tbl_SCAR", dbOpenDynaset, dbReadOnly)
Set childRS = rstMain!NCR_Num.Value
sSearchField = "[SCAR_Num]"
sCriteria = sSearchField & " = " & [SCAR_Num]
With rstMain
.MoveLast
.FindFirst (sCriteria)
With childRS
Do While (Not .EOF)
MsgBox (childRS!NCR_Num.Value)
.MoveNext
Loop
End With
End With
rstMain.Close
dbsMain.Close
Set rstMain = Nothing
Set dbsMain = Nothing
End Function
Any help will be appreciated!
I misunderstood your question, and have updated the answer with the following code. This should do what you want. Replace the code you have in subroutine 'Command_LinkNCR_Click' with the following.
This will: (a) validate nbr exists; (b) add if not present; (c) remove if present;
WARNING!! This code only addresses the one issue you were trying to overcome. However, it makes an update of the same recordset as you are viewing on the form, so there may be an issue if your form is 'Dirty'.
Give this a try and let me know if you have questions.
Private Sub Command_LinkNCR_Click()
Dim dbs As DAO.Database
Dim rsMain As DAO.Recordset
Dim rsChild As DAO.Recordset
Dim strSQL As String
Dim blnMatch As Boolean
If IsNull(Me.Text_NCR) Or Me.Text_NCR = "" Then
MsgBox "No value entered for NCR_Num", vbOKOnly, "Missing Value"
Exit Sub
End If
blnMatch = False
Set dbs = CurrentDb
' Only need to work on the current record
strSQL = "select * from tbl_SCAR where SCAR_Num = " & Me!SCAR_Num & ";"
Set rsMain = dbs.OpenRecordset(strSQL, dbOpenDynaset)
If rsMain.EOF Then
' Should never happen
Else
Set rsChild = rsMain!NCR_Num.Value
If rsChild.EOF Then ' If no values yet, add this new one
MsgBox "Add item"
Else
Do While Not rsChild.EOF
' See if we have a match...
If Int(rsChild.Fields(0)) = Int(Me.Text_NCR) Then
blnMatch = True
rsChild.Delete ' Delete item
Exit Do
End If
rsChild.MoveNext
Loop
If blnMatch = False Then ' Need to Add it
rsMain.Edit
rsChild.AddNew
rsChild.Fields(0) = Me.Text_NCR
rsChild.Update
rsMain.Update
End If
End If
End If
'rsChild.Close
rsMain.Close
dbs.Close
Set rsMain = Nothing
Set rsChild = Nothing
Set dbs = Nothing
Me.Refresh
End Sub
I am trying to run SQL query on sql server (some DWH) and then insert outcome into access table (using VBA).
I did it by using ADODB.Connection, ADODB.Command and ADODB.Recordset. At this point I have my outcome in Recordset and I Wonder how I can insert it into table without looping it.
I tried:
If Not (Rs.EOF And Rs.BOF) Then
Rs.MoveFirst
Do Until Rs.EOF = True
DoCmd.RunSQL ("INSERT INTO Table (F1, F2) VALUES ( " & rs![F1] & ", " & rs[F2] & ")"
Rs.MoveNext
Loop
End If
But Recordset may have over 100k rows. So it would take ages to insert it by using this method.
Another very fast way is to open a new excel workbook paste it into worksheet and then import it. But I would like to avoid it. Is there any other way ?
---------EDITED-----------
Sorry guys. My bad. I was forcing solution with VBA while linkin it was perfect. THANKS !
I was wondering if there is any as fast way which use Access
resources only.
As already mentioned, link the SQL table, then create a simple append query that reads from the linked table and writes to your Access table, and you're done.
I agree with the commenters that you should link if at all possible. But I wanted to see if it could be done. I ended up converting the recordset to a comma delimited file and use TransferText to append it.
Public Sub ImportFromSQLSvr()
Dim rs As ADODB.Recordset
Dim cn As ADODB.Connection
Dim sResult As String
Dim sFile As String, lFile As Long
Const sIMPORTFILE As String = "TestImport.txt"
Set cn = New ADODB.Connection
cn.Open msCONN
Set rs = cn.Execute("SELECT SiteID, StoreNumber FROM Site")
'Add a header row, replace tabs with commas
sResult = rs.GetString
sResult = "SiteID, StoreNumber" & vbNewLine & sResult
sResult = Replace(sResult, vbTab, ",")
'Write to a text file
lFile = FreeFile
sFile = Environ("TEMP") & "\" & sIMPORTFILE
Open sFile For Output As lFile
Print #lFile, sResult
Close lFile
'Append to table dbo_Site
DoCmd.TransferText acImportDelim, , "dbo_Site", Environ("TEMP") & "\" & sIMPORTFILE, True
On Error Resume Next
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub
If you have any commas in your data, you'll need to do some extra work to properly format the csv.