I have two statements in VBA. Here is a fragment of code:
'delete records from tbl_PLAN_data
strErr = "1a"
strSQL = "DELETE tbl_PLAN_data.*"
strSQL = strSQL & " FROM tbl_PLAN_data;"
DBEngine(0)(0).Execute strSQL, dbFailOnError + dbSeeChanges
DoEvents
strErr = "2a"
'append records to tbl_PLAN_data
DBEngine(0)(0).Execute "qryAppPLAN", dbFailOnError + dbSeeChanges
DoEvents
SQL string of qryAppPLAN:
INSERT INTO tbl_PLAN_data ( ID, Qty, QtyPln, QtyAct, ProdT, TmStamp, TID, Wks, vol, v4, v4k, DataPln, Shift, DataPlnShift, GRD, Wk, Wkd, GRDLdKf, KFig )
SELECT tbl_OrderDetailsSub.OrderDetailsSubID, [Quantity]-Sum(Nz([Qtyact],0)*IIf([np]=0,1,-1)) AS Qty, tbl_OrderDetails.Quantity, Sum(Nz([Qtyact],0)*IIf([np]=0,1,-1)) AS QA, Sum(tbl_OrderDetailsSub.PT) AS SumOfPT, Now() AS TmStamp, tbl_OrderDetailsSub.TID, tbl_Tooling.WksID, tbl_OrderDetailsSub.Volume, tbl_OrderDetailsSub.Vol4, tbl_OrderDetailsSub.Vol4K, tbl_OrderDetailsSub.DataPln, tbl_OrderDetailsSub.Shift, [datapln] & "-" & [shift] AS datshift, IIf(InStr([oprdetails],"G")>0 Or InStr([oprdetails],"Hs")>0 And InStr([oprdetails],"GL")=0,1,0) AS GRD, DatePart("ww",[DataPln],0,2) AS w, DatePart("w",[DataPln],0,2) AS wd, tbl_OrderDetailsSub.TblLoadKf, Nz([Koef],1) AS Expr1
FROM ((tbl_Order INNER JOIN (tbl_OrderDetails INNER JOIN tbl_OrderDetailsSub ON tbl_OrderDetails.[OrderDetailsID] = tbl_OrderDetailsSub.[OrderDetailsID]) ON tbl_Order.[OrderID] = tbl_OrderDetails.[OrderID]) LEFT JOIN tbl_ProdAct ON tbl_OrderDetailsSub.[OrderDetailsSubID] = tbl_ProdAct.ODSubID) INNER JOIN tbl_Tooling ON tbl_OrderDetailsSub.TID = tbl_Tooling.TID
WHERE (((tbl_Order.ProdTypeID)<>"S" Or (tbl_Order.ProdTypeID) Is Null) AND ((tbl_Order.CancelledDate) Is Null) AND ((tbl_Order.RefusingReason) Is Null) AND ((Right(CStr(Nz([tbl_Order]![ProcessedDate],"12:00:00")),8))="12:00:00") AND ((tbl_Order.OrderType)<>"Pasiûlymas") AND ((tbl_Order.ShippedDate) Is Null))
GROUP BY tbl_OrderDetailsSub.OrderDetailsSubID, tbl_OrderDetails.Quantity, tbl_OrderDetailsSub.TID, tbl_Tooling.WksID, tbl_OrderDetailsSub.Volume, tbl_OrderDetailsSub.Vol4, tbl_OrderDetailsSub.Vol4K, tbl_OrderDetailsSub.DataPln, tbl_OrderDetailsSub.Shift, [datapln] & "-" & [shift], IIf(InStr([oprdetails],"G")>0 Or InStr([oprdetails],"Hs")>0 And InStr([oprdetails],"GL")=0,1,0), DatePart("ww",[DataPln],0,2), DatePart("w",[DataPln],0,2), tbl_OrderDetailsSub.TblLoadKf, Nz([Koef],1), tbl_OrderDetails.Quantity
HAVING ((([Quantity]-Sum(Nz([Qtyact],0)*IIf([np]=0,1,-1)))>0) AND ((tbl_OrderDetailsSub.DataPln)>Date()-30))
ORDER BY tbl_OrderDetailsSub.DataPln;
Sometimes at second execute statement I get error "Record is deleted". It seems logic when I append records after deletion. But how to force VBA to wait till delete statement completes?
I would suggest you create a Database Object and execute on that object rather than using the DBEngine(0)(0), as when you use this, you are not only performing an expensive operation of creating a new instance of the Database, you are also trying to query the table which you just modified (deleted), so you might have a small glitch.
Dim dbObj As DAO.Database
Set dbObj = CurrentDB()
'delete records from tbl_PLAN_data
strErr = "1a"
strSQL = "DELETE tbl_PLAN_data.* FROM tbl_PLAN_data;"
dbObj.Execute strSQL, dbFailOnError + dbSeeChanges
'Optional
'DoEvents
strErr = "2a"
'append records to tbl_PLAN_data
dbObj.Execute "qryAppPLAN", dbFailOnError + dbSeeChanges
By creating a Database Object, you are making sure the operations are made against the "active" object on which you also made a modification, so would return you the right information. DoEvents might not even be required. I have added it, if you feel it is still causing problems introduce it again and see if it makes any difference.
Good Luck !
Related
I have table with columns like key,English Phrase and that phrase with other 40 languages.See in following image :
I want to break the records of these table by it's language column like following image:
I did this using the following code:
Sub InsertIntoMasterPhrases()
Dim objRecordsetMaster As ADODB.Recordset
Set objRecordsetMaster = New ADODB.Recordset
Dim objRecordset As ADODB.Recordset
Set objRecordset = New ADODB.Recordset
objRecordsetMaster.ActiveConnection = CurrentProject.Connection
objRecordset.ActiveConnection = CurrentProject.Connection
objRecordsetMaster.Open ("SELECT [Master Table].* FROM [Master Table];")
While objRecordsetMaster.EOF = False
objRecordset.Open ("Select [SAP_LANGUAGE to LANG].[LANGUAGE NAME], [SAP_LANGUAGE to LANG].[LANGUAGE] " & _
"From [SAP_LANGUAGE to LANG]")
While objRecordset.EOF = False
key = objRecordsetMaster.Fields("Key").Value
englishPhrase = objRecordsetMaster.Fields("English Phrase").Value
language = objRecordset.Fields("LANGUAGE").Value
translation = objRecordsetMaster.Fields(languageName).Value
If (GetRecordsExist(CStr(key), CStr(englishPhrase), CStr(language)) = "") Then
Query = "INSERT INTO [Language Sample](Key,English,Translation,Language)VALUES ('" & key & "','" & englishPhrase & "','" & translation & "','" & language & "');"
CurrentDb.Execute Query
End If
objRecordset.MoveNext
Wend
objRecordset.Close
objRecordsetMaster.MoveNext
Wend
objRecordsetMaster.Close
End Sub
//Checking records already exist in table
Function GetRecordsExist(key As String, english As String, language As String) As String
Dim db As Database
Dim Lrs As DAO.Recordset
Dim LGST As String
Set db = CurrentDb()
Set Lrs = db.OpenRecordset("SELECT KEY FROM [Language Sample] where KEY='" & key & "' and English='" & english & "' and Language = '" & language & "'")
If Lrs.EOF = False Then
LGST = "Found"
Else
LGST = ""
End If
Lrs.Close
Set Lrs = Nothing
GetRecordsExist = LGST
End Function
In the Master table i have 15000 records and when its breaking 15000 records it becomes 15000 * 40 = 600000. above code inserting almost 10000 records per minutes and after few hour it' hangs up . But also it don't produce any error then i have to restart the access. Kindly help how can i do it in better way.
Alternative 1:
Use a large UNION query to append many records with one SQL statement, as described here:
How to simulate UNPIVOT in Access 2010?
You will probably want to split it into several chunks (e.g. 5 or 10 languages at a time), or Access might choke on the query.
Alternative 2:
Instead of running INSERT statements for each record, use a DAO recordset with .AddNew. This is faster by magnitudes, see this answer:
https://stackoverflow.com/a/33025620/3820271
I am using vba in MS Access to create Invoices in Quickbooks with QODBC.
This process requires multi line invoice items to be inserted first and saved temp till primary invoice information is inserted. I have several invoices that are in need of being inserted as bulk.
EXAMPLE:
MultiLIne (INVOICE ITEMS) = Item #, OrderID, Item Desc, etc.
**MULTILINE matches PRIMARY invoice based on OrderID
Primary (INVOICE) = OrderID, Name, Address, Billing terms, etc.
**Primary is a single line record per orderID
"QB_AppendInvoice_LoopRef" contains the unique orderid's that need to be processed. I was trying to use this as a recordset to import the multiline items based on the current recordset orderid, however, I am unable to reference the current recordset orderid.
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim iCount As Integer
Set db = CurrentDb()
Set rs = db.OpenRecordset("QB_AppendInvoice_LoopRef") 'open the recordset for use (table, Query, SQL Statement)
With rs
If .RecordCount <> 0 Then 'Ensure that there are actually records to work with
'The next 2 line will determine the number of returned records
rs.MoveLast 'This is required otherwise you may not get the right count
iCount = rs.RecordCount 'Determine the number of returned records
Do While Not .BOF
DoCmd.SetWarnings False
'Append Invoice Line (determine tests ordered)
Dim SQL1 As String
SQL1 = "INSERT INTO InvoiceLine (CustomerRefListID, CustomerRefFullName, ARAccountRefListID, ARAccountRefFullName, InvoiceLineSerialNumber, InvoiceLineLotNumber, TemplateRefListID, IsPending, DueDate, TxnDate, InvoiceLineType, InvoiceLineItemRefListID, InvoiceLineItemRefFullName, InvoiceLineDesc, InvoiceLineRate, InvoiceLineAmount, FQSaveToCache, RefNumber)" & _
"SELECT Customer.ListID, Customer.FullName, '4C0000-1070045186', 'Accounts Receivable', Null, Null, '80000023-1495649075', '0', QB_ORDER_DETAILS.OrderDate, QB_ORDER_DETAILS.OrderDate, 'Item', QB_TestList_TestCodes.ListID, QB_TestList_TestCodes.FullName, QB_TestList_TestCodes.Description, QB_TestList_TestCodes.SalesOrPurchasePrice, QB_TestList_TestCodes.SalesOrPurchasePrice, '1', QB_ORDER_DETAILS.OrderID " & _
"FROM ((Customer INNER JOIN contacts ON Customer.AccountNumber = contacts.Company) INNER JOIN QB_ORDER_DETAILS ON contacts.[Full Member Info] = QB_ORDER_DETAILS.Physician) LEFT JOIN QB_TestList_TestCodes ON QB_ORDER_DETAILS.ProductID = QB_TestList_TestCodes.TestCode " & _
"WHERE QB_ORDER_DETAILS.OrderID = rs.Fields.getvalue('OrderID')"
DoCmd.RunSQL SQL1, False
'Append Invoice to Invoice Line (put the tests ordered on an invoice)
Dim SQL2 As String
SQL2 = "INSERT INTO Invoice (CustomerRefListID, CustomerRefFullName, ARAccountRefListID, ARAccountRefFullName, TemplateRefListID, [Memo], IsPending, IsToBePrinted, CustomFieldOther, ItemSalesTaxRefListID, TxnDate, DueDate, RefNumber)" & _
"SELECT Customer.ListID, Customer.FullName, '4C0000-1070045186', 'Accounts Receivable', '80000023-1495649075', [Patient_Last] & ', ' & [Patient_First] & ' - ' & [Full_Specimen_ID], '0', '0', [Patient_Last] & ', ' & [Patient_First] & ' - ' & [Full_Specimen_ID], Null, [OrderDate], [OrderDate], Orders.OrderID" & _
"FROM Customer INNER JOIN (Orders INNER JOIN contacts ON Orders.Physician = contacts.[Full Member Info]) ON Customer.AccountNumber = contacts.Company" & _
"WHERE Orders.OrderID = rs.Fields.getvalue('OrderID')"
DoCmd.RunSQL SQL2, False
.MovePrevious
Loop
Else
MsgBox "There are no records in the recordset."
End If
MsgBox "SENT TO QB - SUCCESS!!!"
End With
rs.Close 'Close the recordset
Set rs = Nothing 'Clean up
DoCmd.SetWarnings True
End Sub
It's because you are updating a string, VBA can't use variables in string like that, here is the correct way of doiing it:
"WHERE Orders.OrderID = " & rs.Fields("OrderID").Value
And if the value is a string, you have to add quotes:
"WHERE Orders.OrderID = '" & rs.Fields("OrderID").Value & "'"
I have two tables that I wish to compare records - based on a field values. Here is what I tried :
Dim RCount As Long
Dim Rst As Recordset
Dim Rst1 As Recordset
Dim f As Field
'Current Record set
Set Rst = CurrentDb.OpenRecordset("Table1")
Set Rst1 = CurrentDb.OpenRecordset("Table2")
With Rst
For Each f In Rst1.Fields
RCount = DCount("FieldFromTable1", "Table1", "[FieldFromTable1]='" & Me.[FieldFromTable2].Value & "'")
If RCount > 0 Then
Me.Checkbox1.Value = True
End If
Next f
End With
Rst.Close
Rst1.Close
Here is my updated question, something like that I'm trying to accomplish. But still this code cycles only through currently selected record in my Table2 form.
Following on from my comment. You can use recordcounts to see if there is a record that exists and matches. You could use the following query to see if a record exists:
dim rst as recordset
dim varSQL as string
varSQL = "SELECT [fieldfromtable1] FROM Table1 WHERE [fieldfromtable1] ='" & [fieldfromtable2].value & "'"
Set Rst = CurrentDb.OpenRecordset(varSQL)
If rst.recordcount = 1 then
MsgBox "Fields have matching values !"
End If
rst.close
You could replace the =1 with >0.
Alternatively, I think you can use dcount() function which would be something like:
dim RCount as long
Rcount = dcount("fieldFromTable1","table1", "[fieldFromTable1]='" & me.[FieldFromTable2].value & "'")
if Rcount > 0 then
MsgBox "Fields have matching values !"
end if
again, you can use >0 or =1 im not sure which is most appropriate for your situation.
Edit
the following query can be performed to update the checkbox, but this isn't at form level
UPDATE table1 INNER JOIN table2 ON table1.[fieldfromtable1] = table2.[fieldfromtable2] SET table1.[checkboxField] = True
WHERE table2.[fieldfromtable2]= table1.[fieldFromtable1]
I haven't really consider an option to just UPDATE records in tables. Thsi is what It worked for me. I was just trying to set Checkbox to TRUE when record from Table1 meets criteria in Table2. A simple UPDATE solved the problem:
Dim SQL As String
niz = " UPDATE Table2" & _
" INNER JOIN Table1" & _
" ON Table1.FieldFromTable1=Table2.FieldFromTable2" & _
" SET Table2.Checkbox1=True"
DoCmd.SetWarnings False
DoCmd.RunSQL niz
DoCmd.Requery
DoCmd.SetWarnings True
My problem is, with each iteration of an update loop, I lose about 100k of memory, so eventually, I get an out of resource error after a few thousand iterations.
The question is, why am I losing memory?
Below is a code fragment which is a loop updating data.
The criteria is extracted from a local database, dao.recordset method. -- rs1
The comparison comes from the target database where the update will be done, dao.recordset method. -- rs2 is the target read to see if I need to do an update
The update is a Docmd.Runsql query into a linked sharepoint table. And yes, I know I could use .edit and .update but in that case other strange things happen for a different post. :)
Access 2010 into Sharepoint 2010
Dim db As DAO.Database
Dim rs1 As DAO.Recordset
Dim rs2 As DAO.Recordset
Set db = CurrentDb
Set rs1 = db.OpenRecordset("datefix")
Do While Not rs1.EOF
Set rs2 = db.OpenRecordset("select `Required delivery` from xyzzy where `SO Line` = '" & rs1.Fields(0).Value & "'")
If rs1.Fields(1).Value = rs2.Fields("Required delivery") Then
Else
DoCmd.RunSQL "update ProblemTracking set `Required delivery` = '" & rs1.Fields(1).Value & "', `1st GI Dat` = '" & rs1.Fields(2).Value & "' where `SO Line` = '" & rs1.Fields(0).Value & "'"
End If
rs2.Close
Set rs2 = Nothing
rs1.MoveNext
Loop
Consider converting your VBA recordsets into one stored action query. You see in SQL, JOIN is considered an explicit join and WHERE is considered an implicit join. Optimizers run these two equivalently. And update queries can use join statements. Moreover, stored queries in contrast to VBA queries are analyzed, optimized, and cached by the database with the optimal execution plan stored internally.
If I read your code correctly, you have three tables: datefix, xyzzy, and ProblemTracking all joined by SO Line (and whatever the corresponding column in dateFix as your example uses field numbers and not names). Basically, you need to update the [Required delivery] and [1st GI Dat] fields in ProblemTracking whenever the corresponding second column of dateFix does not equal [Required delivery] in xyzzy.
Hence, consider saving the below Update Query as its own object and running it in VBA with DoCmd.OpenQuery:
UPDATE (ProblemTracking
INNER JOIN datefix ON ProblemTracking.`SO Line` = datefix.`FirstColumn`)
INNER JOIN xyzzy ON xyzzy.`SO Line` = datefix.`FirstColumn`
SET `Required delivery` = datefix.`SecondColumn`, `1st GI Dat` = datefix.`ThirdColumn`
WHERE datefix.SecondColumn <> xyzzy.`Required delivery`
Now if the above is not an updatedatable query, use a DLookUp():
UPDATE ProblemTracking
INNER JOIN datefix
ON ProblemTracking.`SO Line` = datefix.`FirstColumn`
WHERE datefix.SecondColumn <>
DLookUp("[Required delivery]", "xyzzy", "[SO Line]='" & datefix.FirstColumn & "'")
But if you insist on using VBA recordsets, still considering joining all three tables in a SELECT query where you only use one recordset.
Dim db As DAO.Database
Dim rs As DAO.Recordset
Set db = CurrentDb
' PULLING ONLY NEEDED COLUMNS IN JOIN OF THREE TABLES
strSQL = "SELECT datefix.`FirstColumn`, datefix.`SecondColumn`, datefix.`ThirdColumn`" _
& " FROM (ProblemTracking" _
& " INNER JOIN datefix ON ProblemTracking.`SO Line` = datefix.`FirstColumn`)" _
& " INNER JOIN xyzzy ON xyzzy.`SO Line` = datefix.`FirstColumn`" _
& " WHERE datefix.SecondColumn <> xyzzy.`Required delivery`;"
Set rs = db.OpenRecordset(strSQL)
rs.MoveLast
rs.MoveFirst
Do While Not rs.EOF
DoCmd.RunSQL "UPDATE ProblemTracking
SET `Required delivery` = '" & rs.Fields(1).Value & "',
`1st GI Dat` = '" & rs.Fields(2).Value & "'
WHERE `SO Line` = '" & rs.Fields(0).Value & "'"
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
In a Access 2003 database, I have an "Inscriptions" (subscription) database with a primary key on 2 fields idPersonnel (employee) and idSession.
I have made a form so that user can select a session (in a listbox), then one or more employee (another listbox) and suscribe them to that session by using a button, which, on VBA side, first check that there is enough room on the session (defined by "MaxParticipants" field on "Sessions" table, linked to "Inscriptions" table on idSession), then insert data in "Inscriptions" table
This is working fine in a single-user environnement, but fails if 2 people want to join some employees on the same session at the same time, as I have a confirmation message between check and insertion. Therefore 2 users can select employees, get the confirmation message (at this point both are told there is enough room), resulting in having more people than expected joined to the session.
Fortuneatly, if both users try to insert the same employee(s) to that table, one will get a duplicate error, but insertion will be made if employees are different.
On another DB engine, such as SQL server, I would use a stored procedure that would lock the table, do the check and the insertion then unlock the table.
But it does not seem to be possible in MS Access.
What are the possibilities in MS Access to prevent a session from having more than maximum number of participants ? Any help is appreciated.
One way to accomplish your goal would be to do the INSERT in a transaction, count the participants for that session, and roll back the transaction if the new total exceeds the limit:
Option Compare Database
Option Explicit
Sub AddParticipant()
Dim cdb As DAO.Database, cws As DAO.Workspace, _
qdf As DAO.QueryDef, rst As DAO.Recordset
' test data
Const idPersonnelToAdd = 4
Const idSessionToAdd = 2
Set cdb = CurrentDb
Set cws = DBEngine.Workspaces(0)
cws.BeginTrans
Set qdf = cdb.CreateQueryDef("", _
"PARAMETERS prmIdPersonnel Long, prmIdSession Long; " & _
"INSERT INTO Inscriptions (idPersonnel, idSession) " & _
"VALUES (prmIdPersonnel, prmIdSession)")
qdf!prmIdPersonnel = idPersonnelToAdd
qdf!prmIdSession = idSessionToAdd
qdf.Execute dbFailOnError
Set qdf = Nothing
Set qdf = cdb.CreateQueryDef("", _
"PARAMETERS prmIdSession Long; " & _
"SELECT " & _
"Count(*) AS NumParticipants, " & _
"First(MaxParticipants) AS Limit " & _
"FROM Inscriptions INNER JOIN Sessions " & _
"ON Inscriptions.idSession = Sessions.idSession " & _
"WHERE Sessions.idSession = prmIdSession")
qdf!prmIdSession = idSessionToAdd
Set rst = qdf.OpenRecordset(dbOpenSnapshot)
If rst!NumParticipants <= rst!Limit Then
cws.CommitTrans
Debug.Print "INSERT committed"
Else
cws.Rollback
Debug.Print "INSERT rolled back"
End If
rst.Close
Set rst = Nothing
Set qdf = Nothing
Set cws = Nothing
Set cdb = Nothing
End Sub