VBA Access Inserting from One DAO.Recordset into Another - vba

Within the following code
Dim sqlStr As String
Dim OrgID As Long
Dim wrk As DAO.Workspace
Dim db As DAO.Database
Dim orgRS As DAO.Recordset
Dim staffRS As DAO.Recordset
Set wrk = DBEngine.Workspaces(0)
Set db = CurrentDb
On Error GoTo trans_Err
InsertOrganizationIntoTemp
'if staff fields are not blank Insert Staff into Temp
If (addStaffClickCheck = True) Then
staffNumber = staffNumber + 1
InsertStaffIntoTemp staffNumber
End If
wrk.BeginTrans
sqlStr = "INSERT INTO tblOrganization(OrganizationName, Affiliate, " _
& " UnionCouncil, DateJoined, OrganizationPhoneNumber, OrganizationFaxNumber, " _
& " MembershipGroup, TradeGroup, URL) " _
& " SELECT OrganizationName, Affiliate, CouncilUnion, DateJoined, OrganizationPhone, " _
& " OrganizationFax, MemberGroup, Trade, OrganizationWebsite " _
& " FROM tblTempOrganization;"
db.Execute sqlStr
OrgID = db.OpenRecordset("SELECT ##IDENTITY")(0)
sqlStr = "INSERT INTO tblAddresses(StreetName, CityName, StateName, " _
& " ZipCode, LocationID, OrganizationID) " _
& " SELECT OrganizationAddress, OrganizationCity, OrganizationState, " _
& " OrganizationZIP, OrganizationLocationType, '" & OrgID & "' " _
& " FROM tblTempOrganization;"
db.Execute sqlStr
'pull all staff and phones into two recordsets
'loop through staff and for each staff member add associated phone information
'Recordsets for temporary staff tables
Dim staffTempInfoRS As DAO.Recordset
Dim phoneTempInfoRS As DAO.Recordset
Set staffTempInfoRS = db.OpenRecordset("SELECT * FROM tblTempStaff", dbOpenDynaset)
'Recordsets for permanant staff tables
Dim StaffAddressID As Long
Dim StaffID As Long
'Check to see if the recordset actually contains rows
If Not (staffTempInfoRS.EOF And staffTempInfoRS.BOF) Then
staffTempInfoRS.MoveFirst 'Unnecessary in this case, but still a good habit
Do Until staffTempInfoRS.EOF = True
'address information
Dim staffAddressDBRS As DAO.Recordset
Set staffAddressDBRS = db.OpenRecordset("tblStaffAddresses", dbOpenDynaset)
With staffAddressDBRS
.AddNew
.Fields("StaffStreet") = staffTempInfoRS.Fields("StaffStreet")
.Fields("StaffCity") = staffTempInfoRS.Fields("StaffCity")
.Fields("StaffState") = staffTempInfoRS.Fields("StaffState")
.Fields("StaffZip") = staffTempInfoRS.Fields("StaffZip")
.Update
End With
StaffAddressID = staffAddressDBRS.LastModified
staffAddressDBRS.Close
Set staffAddressDBRS = Nothing
'staff information
Dim staffInfoDBRS As DAO.Recordset
Set staffInfoDBRS = db.OpenRecordset("tblStaff", dbOpenDynaset)
With staffInfoDBRS
.AddNew
.Fields("StaffFirstName") = staffTempInfoRS.Fields("StaffFirstName")
.Fields("StaffLastName") = staffTempInfoRS.Fields("StaffLastName")
.Fields("Email") = staffTempInfoRS.Fields("Email")
.Fields("StaffAddressID") = StaffAddressID
.Fields("OrganizationID") = OrgID
.Fields("Position") = staffTempInfoRS.Fields("StaffPosition")
.Update
End With
Dim currPos As Long
currPos = staffTempInfoRS.Fields("StaffNumber")
StaffID = staffInfoDBRS.LastModified
staffInfoDBRS.Close
Set staffInfoDBRS = Nothing
'staff phone information
Set phoneTempInfoRS = db.OpenRecordset("SELECT * FROM tblTempPhones WHERE StaffNumber = " & currPos & ";")
If Not (phoneTempInfoRS.EOF And phoneTempInfoRS.BOF) Then
phoneTempInfoRS.MoveFirst 'Unnecessary in this case, but still a good habit
Do Until phoneTempInfoRS.EOF = True
Dim phoneInfoDBRS As DAO.Recordset
Set phoneInfoDBRS = db.OpenRecordset("tblStaffPhoneNumbers", dbOpenDynaset)
With phoneInfoDBRS
.AddNew
.Fields("PhoneNumber") = phoneTempInfoRS.Fields("StaffPhoneNumber")
.Fields("PhoneTypeID") = phoneTempInfoRS.Fields("PhoneType")
.Fields("StaffID") = StaffID
.Update
End With
phoneTempInfoRS.MoveNext
Loop
Else
Resume Next
End If
MsgBox "Finished looping through phone records."
phoneTempInfoRS.Close
Set phoneTempInfoRS = Nothing
'Move to the next record. Don't ever forget to do this.
staffTempInfoRS.MoveNext
Loop
Else
MsgBox "There are no records in the staff recordset."
End If
MsgBox "Finished looping through staff records."
staffTempInfoRS.Close 'Close the recordset
Set staffTempInfoRS = Nothing 'Clean up
wrk.CommitTrans
trans_Exit:
'Clean up
wrk.Close
Set db = Nothing
Set wrk = Nothing
Exit Function
trans_Err:
'Roll back the transaction
MsgBox "Whoops! We got errors"
wrk.Rollback
Resume trans_Exit
When I step through this I get an error in this line:
.Fields("StaffStreet") = staffTempInfoRS.Fields("StaffStreet")
That says:
Item not found in collection.
However, this is the exact field name that is in the table that the recordset is set to open.

30 hours later it seems I suffered a rookie mistake and in-spite of repeated checking missed that the field names were indeed misspelled.
I also set the recordsets outside of the loops and I unset them all in the exit snippet...

Related

How to bring a recordset into a table in Access

an access newbie here. I am trying to write a VBA code to query from an SQL database, and append the values into an access table. For this, i wrote below code but so far, i could only write a query and create a connection to the server. But i don't know how to bring it into the access table. Can you help me with this?
Sub getInv()
Dim RowCount As Long, ColCount As Long
Dim cnn As Object
Dim RS As Object
Set cnn = CreateObject("ADODB.Connection")
Set RS = CreateObject("ADODB.Recordset")
Dim SQLQuery As String
SQLQuery = _
"SELECT " & _
"PSDDD.SDDPP, PSDDD.SPPRD " & _
"WHERE " & _
"PSDDD.SDDPP = '2244556'" & _
"ORDER BY " & _
"PSDDD.SDDPP ASC, PSDDD.SPPRD DESC "
ConnectString = _
"DRIVER={Client Access ODBC Driver (32-bit)};" & _
"UID=abbsx;PWD=password;" & _
"SYSTEM=ABCSQT;DBQ=SSTNCHP22DB;"
cnn.Open (ConnectString)
RS.Open SQLQuery, cnn
' I believe i should put the code for writing into access table here.
'Close the Recordset and Connection
RS.Close
cnn.Close
Set RS = Nothing
Set cnn = Nothing
Exit Sub
erden. I hope this code gives you inspiration to solve your problem.
Public Function appendSelectedStudentsIntoPoolTable(Interest As String) As Long
Dim rSQL As String, rParams As String
Dim aSQL As String, aParams As String
Dim sourceTable As String, targetTable As String
sourceTable = "tStudents"
targetTable = "tStudentsPool"
'Note for targetTable: ID column not set to autonumber because to preserve
'original data as in the source table. But you can use it as PK as long no
'duplication on IDs.
rParams = "PARAMETERS [par_interest] Text(50); "
rSQL = rParams & "SELECT ID, Email, FirstName " & _
"FROM " & sourceTable & _
" WHERE Interest = par_interest;"
aParams = "PARAMETERS [par_ID] Long, [par_Email] Text(255), " & _
"[par_FirstName] Text(50); "
aSQL = aParams & "INSERT INTO " & targetTable & _
" (ID, Email, FirstName) " & _
"VALUES (par_ID, par_Email, par_FirstName);"
Dim db As DAO.Database
Dim rQDf As DAO.QueryDef
Dim aQdf As DAO.QueryDef
Dim rs As DAO.Recordset
Dim rec As Variant
Dim rsCount As Long 'change data type as needed
Dim appendedCount As Long 'same as rsCount data type
Dim i As Long 'same as rsCount data type
'On Error GoTo commit_failed
Set db = CurrentDb
Set rQDf = db.CreateQueryDef("", rSQL)
rQDf.Parameters("par_interest") = Interest
Set rs = rQDf.OpenRecordset()
With rs
On Error Resume Next: .MoveLast
On Error Resume Next: .MoveFirst
If .RecordCount > 0 Then
Do While Not rs.EOF
Set aQdf = db.CreateQueryDef("", aSQL)
aQdf.Parameters("par_ID") = !ID
'add routine(s) to check existing ID on pool table here
'before record append to pool table
'to prevent duplicate ID. For now, i skip it.
aQdf.Parameters("par_Email") = !Email
aQdf.Parameters("par_FirstName") = !FirstName
aQdf.Execute dbFailOnError
aQdf.Close
appendedCount = appendedCount + 1
.MoveNext
Loop
.Close
rQDf.Close
End If
End With
appendSelectedStudentsIntoPoolTable = appendedCount: Exit Function
commit_failed:
appendSelectedStudentsIntoPoolTable = 0
'You can put error handler here
End Function

SQL Parameter Prompt

I'm trying to run a SQL command in VBA to delete certain records from a table. When I run it I'm prompted for parameters. What is causing this? I have included the subroutine that includes the SQL.
Public Sub AddCon(newCont, svID)
Dim daDb As DAO.Database
Dim rst1 As Recordset
Dim rst2 As Recordset
Dim selContract As String
Set daDb = CurrentDb
Set rst1 = daDb.OpenRecordset("tblContracts")
Set rst2 = daDb.OpenRecordset("tblContractList")
rst2.AddNew
rst2!Contract = newCont
rst2!ID = svID
rst2.Update
rst2.Close
Set rst2 = Nothing
DoCmd.Close
Dim strSQL As String
strSQL = "DELETE * FROM [tblContractList] " _
& "WHERE rst1.Contract <> newCont"
DoCmd.RunSQL strSQL
DoCmd.OpenForm "frmContracts"
End Sub
As you make query,
DELETE * FROM [tblContractList] WHERE rst1.Contract <> newCont;
Microsoft Access engine will ask for you two unknowns via prompt: rst1.Contract and newCont.
So you should replace them with known values:
Public Sub AddCon(newCont, svID)
Dim daDb As DAO.Database
'Dim rst1 As Recordset
Dim rst2 As Recordset
' Dim selContract As String
Set daDb = CurrentDb
'Set rst1 = daDb.OpenRecordset("tblContracts")
Set rst2 = daDb.OpenRecordset("tblContractList")
rst2.AddNew
rst2!Contract = newCont
rst2!ID = svID
rst2.Update
rst2.Close
Set rst2 = Nothing
'DoCmd.Close
Dim strSQL As String
'
' DELETE query must be run with care, as useful data may disappear!!!
'
strSQL = "DELETE * FROM tblContractList " _
& "WHERE (Contract " & " <> " & newCont & ")"
'
' or single quoting newCont if it is a string:
'
'strSQL = "DELETE * FROM tblContractList " _
' & "WHERE (Contract " & " <> '" & newCont & "')"
'
'rst1.Close
'Set rst1 = Nothing
Set daDb = Nothing
DoCmd.RunSQL strSQL
DoCmd.OpenForm "frmContracts"
End Sub

How do I loop using multiple conditions for a submit button?

I am writing a function that checks if the amount paid is equal or more to a number of items selected if they are checked. For this example there are 10 items with 10 check boxes. I could check one or more boxes in any order.If an item or more meets the condition it is cleared otherwise it remains.
Public Sub processItem1()
Dim db As DAO.Database
Dim pr As DAO.Recordset, so As DAO.Recordset
Dim strSQL1 As String
Dim strSQL2 As String
Set db = CurrentDb
strSQL1 = "SELECT * FROM PharmSales WHERE PharmSalesID= (SELECT MAX(PharmSalesID) FROM PharmSales WHERE HospitalNo='" & Me.txtRegNo & "' And TDate = #" & Format(Me.txtTDate, "M\/dd\/yyyy") & "# AND SalesItem1 = '" & Me.txtSalesItem1 & "')"
strSQL2 = "SELECT * FROM tblItem WHERE ItemName = '" & Me.txtSalesItem1 & "'"
Set pr = db.OpenRecordset(strSQL1)
Set so = db.OpenRecordset(strSQL2)
With pr
If Not .BOF And Not .EOF Then 'Ensure that the recordset contains records
.MoveLast
.MoveFirst
If .Updatable Then 'To ensure record is not locked by another user
.Edit 'Must start an update with the edit statement
![DispQty1] = Nz(![DispQty1] + Me.txtSalesQty1.Value, 0)
.Update
End If
End If
pr.Close 'Make sure you close the recordset..
Set pr = Nothing '...and set it to nothing
Set db = Nothing
End With
With so
If Not .BOF And Not .EOF Then 'Ensure that the recordset contains records
.MoveLast
.MoveFirst
If .Updatable Then 'To ensure record is not locked by another user
.Edit 'Must start an update with the edit statement
![Stock_Out] = Nz(![Stock_Out] + Me.txtSalesQty1.Value, Me.txtSalesQty1.Value)
![SO_Date] = Me.txtTDate
![Stock_In] = Nz(![Stock_In] + 0, 0)
.Update 'And finally we will need to confirm the update
End If
End If
so.Close 'Make sure you close the recordset..
ExitSub:
Set so = Nothing '...and set it to nothing
Set db = Nothing
End With
End Sub
For processItem2:
Public Sub processItem2()
Dim db As DAO.Database
Dim pr As DAO.Recordset, so As DAO.Recordset
Dim strSQL1 As String
Dim strSQL2 As String
Set db = CurrentDb
strSQL1 = "SELECT * FROM PharmSales WHERE PharmSalesID= (SELECT MAX(PharmSalesID) FROM PharmSales WHERE HospitalNo='" & Me.txtRegNo & "' And TDate = #" & Format(Me.txtTDate, "M\/dd\/yyyy") & "# AND SalesItem2 = '" & Me.txtSalesItem2 & "')"
strSQL2 = "SELECT * FROM tblItem WHERE ItemName = '" & Me.txtSalesItem2 & "'"
Set pr = db.OpenRecordset(strSQL1)
Set so = db.OpenRecordset(strSQL2)
With pr
If Not .BOF And Not .EOF Then 'Ensure that the recordset contains records
.MoveLast
.MoveFirst
If .Updatable Then 'To ensure record is not locked by another user
.Edit 'Must start an update with the edit statement
![DispQty2] = Nz(![DispQty2] + Me.txtSalesQty2.Value, 0)
.Update
End If
End If
pr.Close 'Make sure you close the recordset..
Set pr = Nothing '...and set it to nothing
Set db = Nothing
End With
With so
If Not .BOF And Not .EOF Then 'Ensure that the recordset contains records
.MoveLast
.MoveFirst
If .Updatable Then 'To ensure record is not locked by another user
.Edit 'Must start an update with the edit statement
![Stock_Out] = Nz(![Stock_Out] + Me.txtSalesQty2.Value, Me.txtSalesQty2.Value)
![SO_Date] = Me.txtTDate
![Stock_In] = Nz(![Stock_In] + 0, 0)
.Update 'And finally we will need to confirm the update
End If
End If
so.Close 'Make sure you close the recordset..
ExitSub:
Set so = Nothing '...and set it to nothing
Set db = Nothing
End With
End Sub
Don't ever copy&paste code like this. It is a maintenance nightmare.
You can loop over objects by concatenating their name at runtime:
Me("txtSalesItem" & i) ' form control
pr("DispQty" & i).Value ' recordset field
etc.
Side note:
With recordset
.MoveLast
.MoveFirst
These MoveLast/MoveFirst commands are unnecessary. You only need them if you want to get the correct .RecordCount of a recordset.

Looping through Table Records to Update another Tables Records based on a Key Identifier

I keep having issues with this query saying there are no reocrds but I know there are because I am looking at the table. I want to loop through a table to find certain column information based off a few parameters on the click of a button.
So when I click my button it'll loop through table one find the fields I need based on the ID and update the other table with those fields.
Private Sub GetResults_Click()
Dim strSQL As String
Dim SQL As String
Dim dba As Database
Dim tbl As Recordset
Dim rst1 As Recordset
Dim tstdt As Date
tstdt = Me.Date.Value
Set dba = CurrentDb
Set tbl = dba.OpenRecordset("tbl_Results", dbOpenDynaset, dbSeeChanges)
strSQL = "SELECT * FROM tbl_Results"
Set tbl = dba.OpenRecordset(strSQL, dbOpenDynaset, dbSeeChanges)
If Not tbl.EOF Then
With tbl
.MoveFirst
Do Until tbl.EOF
Call getDataRecords(tbl!SystemAssignedPersonID, tstdt)
.MoveNext
Loop
End With
End If
Set rst1 = Nothing
Set tbl = Nothing
Set dba = Nothing
End Sub
Function getDataRecords(PersonID As Variant, TestDate As Date)
Dim dba As Database
Dim rst As Recordset
Dim rst1 As Recordset
Dim SQL As String
Set dba = CurrentDb
Set rst = dba.OpenRecordset("tbl_Results", dbOpenDynaset, dbSeeChanges)
Set rst1 = dba.OpenRecordset("dbo_tbl_Random", dbOpenDynaset, dbSeeChanges)
SQL = "SELECT * FROM dbo_tbl_Random WHERE SystemAssignedPersonID = " & PersonID & " AND Date = " & Date & " AND MenuUsed = 'RandomResult'"
Set rst1 = dba.OpenRecordset(SQL, dbOpenDynaset, dbSeeChanges)
rst.AddNew
rst.Fields("FileSent") = rst1!FileSent
rst.Fields("Result") = rst1!Result
rst.Update
End Function
Help before I go nuts! Thanks!
You're over-complicating things here. All this can be done in 1 SQL statement
Update tbl_Results as Res
Inner join dbo_tbl_Random as rand
on Res.PersonID = Rand.SystemAssignedPersonID and Res.[Date] = Rand.[Date]
set Res.FileSent = Rand.FileSent ,
Res.Result = Rand.Result
Where Rand.MenuUsed = 'RandomResult'
You can execute like this
dim sql as string
sql = "Update tbl_Results as Res " & _
"Inner join dbo_tbl_Random as rand " & _
" on Res.PersonID = Rand.SystemAssignedPersonID and Res.[Date] = Rand.[Date] " & _
"set Res.FileSent = Rand.FileSent , " & _
" Res.Result = Rand.Result " & _
" Where Rand.MenuUsed = 'RandomResult' "
CurrentDb.Execute(sql)
Update:
This is how I am expecting your tables are set up
tbl_results
dbo_tbl_Random
How I set up the query in the designer to confirm it is working

vba to populate a textbox from SQL queries when combobox is change it

I have a userform with one textbox and one combobox in EXCEL.
This userform is connected to a small data base (one table with 2 columns)
Combobox is populated with the values from the first column of databasqe table
I like when the combobox is changing the textbox to be automatic populated with the corespondent value from the second column.
I have the following code but it is not working:
Please, can someone help me?
Sub PopulateTB()
Dim rs As Recordset
Dim db As database
Dim SQL As String
Set db = OpenDatabase(ThisWorkbook.Path & "\materiale.mdb")
SQL = "SELECT values_col2 FROM table_db WHERE values_col1 = " & UserForm1.ComboBox1.Value & ";"
Set rs = db.OpenRecordset(sql)
Do Until rs.EOF = True
UserForm1.TextBox1.Value = rs.Fields(SQL)
rs.MoveNext
Loop
rs.Close
Set db = Nothing
Set rs = Nothing
End Sub
Thank you!
I putted like this and it is ok
Sub PopulateTB(ByRef ctl As Control, ByVal strTable As String, ByVal strField As String, Optional ByVal strCriteria As String)
Dim strSQL As String
Dim strSQLcount As String
Dim rs As Recordset
Dim db As Database
Dim rsCount As Recordset, totalCol As Long
Dim varRecords As Variant
Set db = OpenDatabase(ThisWorkbook.Path & "\materiale.mdb")
strSQLcount = ""
strSQLcount = strSQLcount & " " & "SELECT COUNT(*) AS Total FROM " & "[" & strTable & "]"
Set rsCount = db.OpenRecordset(strSQLcount)
totalCol = rsCount!Total
rsCount.Close
Set rsCount = Nothing
strSQL = ""
strSQL = strSQL & " " & "SELECT" & "[" & strField & "]"
strSQL = strSQL & " " & "FROM " & "[" & strTable & "]"
Set rs = db.OpenRecordset(strSQL)
varRecords = rs.GetRows(totalCol)
ctl.Value = varRecords(0, Me.ComboBox1.ListIndex)
rs.Close
db.Close
Set db = Nothing
Set rs = Nothing
End Sub