Access DAO Inserting whole record into Another Recordset - vba

I am trying to move all of the cords from one recordset to another and was wondering if a specific method could do this. Here is my code.
Dim maxDate As Variant
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim destin As DAO.Recordset
maxDate = DMax("[Eff Date]", "400_CF_BREAK_LOG")
Set db = CurrentDb
Set rs = db.OpenRecordset("860_APPEND_DIFFERENCES") 'myTable is a MS-Access table created previously
Set destin = db.OpenRecordset("400_CF_BREAK_LOG")
'populate the table
rs.MoveFirst
Do While Not rs.EOF
If (rs![Eff Date] > maxDate) Then
destin.
Debug.Print (rs!myField) 'myField is a field name in table myTable
rs.MoveNext
Loop
I am caught at the destin. <---- Add the whole record here.
EDIT. The chosen answer while correct, might not account for a differing number of fields between tables. I find myself using this set-up for adding three different recordsets. Taken from Insert Complete RecordSet to another table in other database MS Access
maxDate = DMax("[Eff Date]", "400_CF_BREAK_LOG")
Set db = CurrentDb
Set rs = db.OpenRecordset("mytable") 'myTable is a MS-Access table created previously
'populate the table
rs.MoveFirst
Do While Not rs.EOF
If (rs![Eff Date] > maxDate) Then
sqlinsert = "INSERT INTO 400_CF_BREAK_LOG (Eff Date, PrimarySecurity ID Number, CUSIP(Aladdin ID), IsrName, Asset Type, Metlife Port Code, Business Unit, Principal Difference, Total PAM Principal, Total Aladdin Principal,Income Difference, Total PAM Interest,Total Aladdin Interest,Total CF Difference,Total PAM CF,PAM Coupon)" & _
" VALUES ('" & rs("Eff Date") & "', '" & rs("PrimarySecurity ID Number") & "', '" & rs("CUSIP(Aladdin ID)") & "', '" & rs("IsrName") & "', '" & rs("Asset Type") & "', '" & rs("Metlife Port Code") & "', '" & rs("Business Unit") & "', '" & rs("Principal Difference") & "', '" & rs("Total PAM Principal") & "', '" & rs("Total Aladdin Principal") & "', & '" & rs("Income Difference") & "', '" & rs("Total PAM Interest") & "', '" & rs("Total Aladdin Interest") & "', '" & rs("Total CF Difference") & "', '" & rs("Total PAM CF") & "', '" & rs("PAM Coupon") & "')"
DoCmd.RunSQL (sqlinsert)
rs.MoveNext
Loop

You can modify this to your need (here source and target is the same table):
Public Sub CopyRecords()
Dim rstSource As DAO.Recordset
Dim rstInsert As DAO.Recordset
Dim fld As DAO.Field
Dim strSQL As String
Dim lngLoop As Long
Dim lngCount As Long
strSQL = "SELECT * FROM tblStatus WHERE Location = '" & _
"DEFx" & "' Order by Total"
Set rstInsert = CurrentDb.OpenRecordset(strSQL)
Set rstSource = rstInsert.Clone
With rstSource
lngCount = .RecordCount
For lngLoop = 1 To lngCount
With rstInsert
.AddNew
For Each fld In rstSource.Fields
With fld
If .Attributes And dbAutoIncrField Then
' Skip Autonumber or GUID field.
ElseIf .Name = "Total" Then
' Insert default job code.
' datNow = Now
rstInsert.Fields(.Name).Value = 0
ElseIf .Name = "PROCESSED_IND" Then
rstInsert.Fields(.Name).Value = vbNullString
Else
' Copy field content.
rstInsert.Fields(.Name).Value = .Value
End If
End With
Next
' Insert fields not existing in source table
rstInsert!SomeField.Value = SomeValue
rstInsert!SomeOtherField.Value = SomeOtherValue
rstInsert!YetAField.Value = ThirdValue
.Update
End With
.MoveNext
Next
rstInsert.Close
.Close
End With
Set rstInsert = Nothing
Set rstSource = Nothing
End Sub

Related

Increase speed of multiple inserts into Access DB from VBA Dictionary

I am attempting to take a VBA Dictionary and either:
Insert a new row into the database if it does not exist
Update the row if it does
While my current code works for this, it runs extremely slowly for the thousands of records I may need to update, and other solutions I have found on this site do not really achieve what I am after. Could anyone help me achieve this? My code so far is below:
Sub UpdateDatabase(dict As Object)
Dim Conn As Object, StrSQL As String, Rs As Object
Dim hmm As ADODB.Recordset
Set Conn = CreateObject("ADODB.Connection")
Conn.Provider = "Microsoft.ACE.OLEDB.12.0"
Conn.Open "C:\XXXX\cfrv2.accdb"
dictCount = dict.Count
counter = 0
For Each varKey In dict.Keys()
Application.StatusBar = Str(counter) & "/" & Str(dictCount)
counter = counter + 1
StrSQL = "SELECT * FROM `All SAMs Backlog` WHERE [LOCID] = '" & varKey & "'"
Set hmm = Conn.Execute(StrSQL)
If hmm.BOF And hmm.EOF Then
StrSQL = "INSERT INTO `ALL SAMs Backlog` ([SAM], [LOCID], [RTC Date], [CFR Status], [CFR Completed Date], [CFR On Hold Reason], [MDU], [ICWB Issue], [Obsolete]) VALUES (dict.Item(varKey)(0), '" & varKey & "', '20/12/2018', '" & dict.Item(varKey)(1) & "', '02/01/2019', '" & dict.Item(varKey)(2) & "' , '" & dict.Item(varKey)(3) & "' , '" &dict.Item(varKey)(4) & "' , '" & dict.Item(varKey)(5) & "')"
Conn.Execute (StrSQL)
Else
'Update the LOC in the table
StrSQL = "UPDATE `All SAMs Backlog` SET ([CFR Status] = '" & dict.Item(varKey)(1) & "', [CFR On Hold Reason] = '" & dict.Item(varKey)(2) & "', [MDU] = '" & dict.Item(varKey)(3) & "', [ICWB Issue] = '" & dict.Item(varKey)(4) & "', [Obsolete] = '" & dict.Item(varKey)(5) & "')"
Conn.Execute (StrSQL)
End If
Next
Conn.Close
End Sub
Any help is appreciated.
Either:
Write the content of the dictionary to a temp table, then run a query as described here:
Update or insert data in table
or:
Open [All SAMs Backlog] as a recordset, loop the dictionary to add or edit records as needed, then close the recordset.

VBA + SQL Server - Get Last ID Inserted

Hope you can help - I'm having issues getting the last ID after INSERT.
So the environment - Access 2016, SQL Server and VBA
Dim db As DAO.Database
Dim RS As New ADODB.Recordset
Dim sql As String
I have theses declared and then private sub.
Private Sub CreateOrderHeader()
Dim CustomerID As Integer
Dim OrderDate As String
Dim OrderStatus As String
Dim OrderValue As Double
Dim OrderNotes As String
Dim OrderPostageID As String
Dim OrderAddressID As String
Dim OrderBatchID As Integer
Dim OrderPayment As String
Dim OrderCourierID As String
Dim OrderAgentID As Integer
Dim OrderOutstanding As Double
CustomerID = tbxCusID
OrderDate = Format(Now)
OrderStatus = "InProcess"
OrderValue = txtTotal.value
OrderNotes = tbxNotes.value
OrderPostageID = txtPostage.Column(0)
If tbxCustomerAddress = tbxDeliveryAddress Then
OrderAddressID = 3 'default customers address
Else
'NEED TO GET CUSTOMER ADDRESS TO DO
End If
OrderBatchID = cmbBatch.Column(0)
OrderPayment = sPayMethod
OrderCourierID = cbxShipping.Column(0)
OrderAgentID = 0
OrderOutstanding = txtTotal.value
Dim testvar As String
sql = "INSERT INTO dbo_OrderHeader " _
& "(OrdCusID, OrdDate, OrdStatus, OrdValue, OrdNotes, OrdPostageID, OrdDelAddID,OrdBatchID,OrdPaymentMethod, OrdCourierID,ordAgentID, OrdOutstanding,OrdSource) " _
& " VALUES ('" & CustomerID & "' ,'" & OrderDate & "', '" & OrderStatus & "', '" & OrderValue & "', '" & OrderNotes & "', '" & OrderPostageID & "','" & OrderAddressID & "','" & OrderBatchID & "','" & OrderPayment & "','" & OrderCourierID & "','" & OrderAgentID & "','" & OrderOutstanding & "', 1)"
DoCmd.RunSQL (sql)
sql = "SELECT ##IDENTITY As IDT"
RS.Open sql, CurrentProject.Connection, adOpenStatic, adLockReadOnly
IDT = RS!IDT
MsgBox ("Succes - OrderHeader" & " '" & IDT & "' ")
End Sub
I was expecting a result from this code:
sql = "SELECT ##IDENTITY As IDT"
RS.Open sql, CurrentProject.Connection, adOpenStatic, adLockReadOnly
IDT = RS!IDT
But that gives me "0" as result.
Can you help please.
Thanks
You can try this :
Set db = CurrentDB
db.Execute(sql)
IDT = db.OpenRecordset("SELECT ##IDENTITY")(0)
Set db = Nothing
NOTE
Don't execute your insert query like DoCmd.RunSQL (sql) Instead follow the above approach.

form not found error. MS Access SQL

I'm getting an error saying that Access cannot find the referenced form CFRRR but there is definitely a form there. Not sure if I'm just not writing the code correctly.
Public Function AssignNullProjects() As Long
Dim db As dao.Database
Dim rs As dao.Recordset
Dim strSQL As String
Set db = CurrentDb
strSQL = "SELECT CFRRRID, [program], [language] FROM CFRRR WHERE assignedto Is Null"
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
If Not rs.BOF And Not rs.EOF Then
While Not rs.EOF
strSQL = "UPDATE CFRRR SET assignedto = " & GetNextAssignee & ", assignedby = " & [Forms]![CFRRR]![assignedby] & ", Dateassigned = #" & Now & "#, actiondate = #" & Now & "#, Workername = " & _ [Forms]![CFRRR]![assignedto] & ", WorkerID = " & [Forms]![CFRRR]![assignedto] & " WHERE CFRRRID = " & rs!CFRRRID
db.Execute strSQL, dbFailOnError
rs.MoveNext
Wend
End If
rs.Close
db.Close
Set rs = Nothing
Set db = Nothing
End Function
Public Function GetNextAssignee(program As String, Language As String) As Long
' Returns UserID as a Long Integer with the lowest [TS] value,
' and updates same [TS] by incremented with 1.
Dim db As dao.Database
Dim rs As dao.Recordset
Dim strSQL As String
Set db = CurrentDb
strSQL = "SELECT TOP 1 WorkerID FROM attendance WHERE [Programs] LIKE '*" & program & "*' AND [Language] = '" & Language & "' AND [Status] = '" & Available & "' ORDER BY TS ASC"
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
If Not rs.BOF And Not rs.EOF Then
'Found next assignee, update date/time stamp
'strSQL = "UPDATE tblUser SET TS = " & DMax("[TS]", tblUser) + 1 & " WHERE [WorkerID]= " & rs!workerid
strSQL = "UPDATE attendance SET TS = " & DMax("[TS]", "attendance") + 1 & " WHERE [WorkerID]= " & rs!workerid
db.Execute strSQL, dbFailOnError
GetNextAssignee = rs!workerid
Else
'Field TS has NO VALUE FOR ALL RECORDS!
'Code calling this function should check for a return of 0 indicating an error.
GetNextAssignee = 0
End If
rs.Close
db.Close
Set rs = Nothing
Set db = Nothing
End Function

Excel VBA Selecting Records from Access Database Not Pulling Correctly

I have a macro that pulls from an Access DB and writes the recordset to the spreadsheet based upon dates that are entered into a userform. However, if I enter in "3/2/2105" and "3/5/2015" it returns all the records from 3/2-3/5 and then 3/20-3/31. I cannot think of any reason why it would do this. If anybody could point me in the right direction/make suggestions it would be greatly appreciated.
Sub pullfrommsaccess()
queryform.Show
Dim conn As Object
Dim rs As Object
Dim AccessFile As String
Dim SQL As String
Dim startdate As String
Dim enddate As String
Dim i As Integer
Sheet2.Cells.Delete
Application.ScreenUpdating = False
AccessFile = ThisWorkbook.Path & "\" & "mdidatabase.accdb"
On Error Resume Next
Set conn = CreateObject("ADODB.connection")
If Err.Number <> 0 Then
MsgBox "Connection was not created!", vbCritical, "Connection Error"
Exit Sub
End If
On Error GoTo 0
conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessFile
If tblname = "Attainments" Then
If shift1 = "1" Then
SQL = "SELECT [Line],[Area],[Shift],[Attainment Percentage],[Date] FROM " & tblname & " WHERE Shift='1' and Date Between " & "'" & pastdate & "' " & "and" & " '" & currentdate & "'"
End If
If shift2 = "2" Then
SQL = "SELECT [Line],[Area],[Shift],[Attainment Percentage],[Date] FROM " & tblname & " WHERE Shift='2' and Date Between " & "'" & pastdate & "' " & "and" & " '" & currentdate & "'"
End If
If shift1 = "1" And shift2 = "2" Then
SQL = "SELECT [Line],[Area],[Shift],[Attainment Percentage],[Date] FROM " & tblname & " WHERE Date Between " & "'" & pastdate & "' " & "and" & " '" & currentdate & "'"
End If
End If
If tblname = "MDItable" Then
If shift1misses = "1" Then
SQL = "SELECT [Date],[Area],[Shift],[Line],[Quantity],[Issue] FROM " & tblname & " WHERE Shift='1' and Date Between " & "'" & pastdatemisses & "' " & "and" & " '" & currentdatemisses & "'"
End If
If shift2misses = "2" Then
SQL = "SELECT [Date],[Area],[Shift],[Line],[Quantity],[Issue] FROM " & tblname & " WHERE Shift='2' and Date Between " & "'" & pastdatemisses & "' " & "and" & " '" & currentdatemisses & "'"
End If
If shift1misses = "1" And shift2misses = "2" Then
SQL = "SELECT [Date],[Area],[Shift],[Line],[Quantity],[Issue] FROM " & tblname & " WHERE Date Between " & "'" & pastdatemisses & "' " & "and" & " '" & currentdatemisses & "'"
End If
End If
On Error Resume Next
Set rs = CreateObject("ADODB.Recordset")
If Err.Number <> 0 Then
Set rs = Nothing
Set conn = Nothing
MsgBox "Recordset was not created!", vbCritical, "Recordset Error"
Exit Sub
End If
On Error GoTo 0
rs.CursorLocation = 3
rs.CursorType = 1
rs.Open SQL, conn
If rs.EOF And rs.BOF Then
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
Application.ScreenUpdating = True
MsgBox "There are no records in the recordset!", vbCritical, "No Records"
Exit Sub
End If
For i = 0 To rs.Fields.Count - 1
Sheet2.Cells(1, i + 1) = rs.Fields(i).Name
Next i
'Copy From RecordSet to Excel and Reset
Sheet2.Range("A2").CopyFromRecordset rs
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
MsgBox "The records from " & pastdate & " and " & currentdate & " were successfully retrieved from the '" & tblname & "' table!", vbInformation, "Done"
End If
Call TrimALL
End Sub
You have a field named Date, try renaming that and reworking the code as in first instance that's a reserved word and is a bad idea for starters!
When working with dates, see Allen Browne's comments on the matter here for consistency;
http://allenbrowne.com/ser-36.html
You have your dates declared as string, but in your SQL query you're surrounding them with a ' not a #. It should read;
Date Between " & "#" & pastdate & "# " & "and" & " #" & currentdate & "#"
All of the above should sort you out, if not comment and I'll take a much closer look for you!

Updating Access Database using UPDATE SQL statement in VBA

Can someone take a look a the stSQL string and help me fix the syntax error I am getting associated with the UPDATE statement?
Run-time error '-2147217900 (8004e14)': Syntax error in UPDATE statement.
I have a rudimentary understanding of SQL and don't seem to understand where I have gone wrong.
I want to update the fields of Table 1 if the FileName UserForm value matches a FileName field in the Access Db.
Thanks
Public Sub UpdateDatabaseEntry()
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim stDB As String, stSQL As String, stProvider As String
Dim FileName As String
Dim Nickname As String
Dim RecipientName As String
Dim RecipientRelationship As String
Dim Summary As String
Dim Noteworthy As String
Dim PreparedBy As String
FileName = UserForm1.FileNameTextBox.Text
Nickname = UserForm1.NicknameTextBox.Text
RecipientName = UserForm1.RecipientNameTextBox.Text
RecipientRelationship = UserForm1.RecipientRelationshipComboBox.Text
Summary = UserForm1.SummaryTextBox.Text
Noteworthy = UserForm1.NoteworthyCheckBox.Value
PreparedBy = UserForm1.PreparedByTextBox.Text
stDB = "Data Source= E:\MyDb.accdb"
stProvider = "Microsoft.ACE.OLEDB.12.0"
//Opening connection to database
With cn
.ConnectionString = stDB
.Provider = stProvider
.Open
End With
//SQL Statement telling database what to do
stSQL = "UPDATE Table1" & _
"SET Nickname= '" & Nickname & "', RecipientName= '" & RecipientName & "', " & _
"RecipientRelationship= '" & RecipientRelationship & "', Summary= '" & Summary & "', " & _
"Noteworthy= '" & Noteworthy & "', PreparedBy= '" & PreparedBy & "', " & _
"WHERE FileName= '" & FileName & "'"
cn.Execute stSQL
cn.Close
Set rs = Nothing
Set cn = Nothing
End Sub
At least one problem is caused by lack of spaces in the query. So your query started UPDATE Table1set.
stSQL = "UPDATE Table1 " & _
"SET Nickname= '" & Nickname & "', RecipientName= '" & RecipientName & "', " & _
"RecipientRelationship= '" & RecipientRelationship & "', Summary= '" & Summary & "', " & _
"Noteworthy= '" & Noteworthy & "', PreparedBy= '" & PreparedBy & "'" & _
"WHERE FileName= '" & FileName & "'"
If this doesn't fix the problem. Then edit your question with the value of stSQL after the variable substitution.
EDIT:
As TS points out, another problem is the , before the where (fixed above).