I am currently creating a database for our company and I would need to add a Customer ID to each new record.
I designed a data entry form and have the following Module running on it to create the ID:
Option Compare Database
Function NewCustomerIDCode() As Long
Dim db As Database
Dim LSQL As String
Dim LUpdate As String
Dim Lrs As DAO.Recordset
Dim LNewCustomerIDCode As Long
On Error GoTo Err_Execute
Set db = CurrentDb()
'Retrieve last number assigned for Customer ID Code
LSQL = "Select Last_Nbr_Assigned from CustomerIDCode"
LSQL = LSQL & " where Code_Desc = 'Customer ID Code'"
Set Lrs = db.OpenRecordset(LSQL)
'If no records were found, return an error
If Lrs.EOF = True Then
LNewCustomerIDCode = 0
MsgBox "There was no entry found in the Codes table for Customer ID Code."
Else
'Determine new Customer ID Code
LNewCustomerIDCode = Lrs("Last_Nbr_Assigned") + 1
'Increment Customer ID Code in CustomerIDCode table by 1
LUpdate = "Update CustomerIDCode"
LUpdate = LUpdate & " set Last_Nbr_Assigned = " & LNewCustomerIDCode
LUpdate = LUpdate & " where Code_Desc = 'Customer ID Code'"
db.Execute LUpdate, dbFailOnError
End If
Lrs.Close
Set Lrs = Nothing
Set db = Nothing
NewCustomerIDCode = LNewCustomerIDCode
Exit Function
Err_Execute:
'An error occurred, return 0
NewCustomerIDCode = 0
MsgBox "An error occurred while trying to determine the next Customer ID Code to assign."
End Function
The problem is, if for example someone starts entering data in this form an ID is assigned (example: 1023). If for any reason they decide not to finsh the entry and delete the record, the next entry will get number (example: 1024). But I would need 1023 to be reused because it is not linked to a record. For accounting reasons I cannot have this number skip.
On the other hand if the new record is created and for whatever reason is deleted in a year, it's number cannot be reused. For example we delete record 1023 but our last entered record is 1145 the next record should get 1146 and not the deleted n° 1023.
Just for some background info I have a separate Autonumber for the primary key. This is not visible to users and has no meaning to the record except for Access to have a unique number for each record.
Can someone help? I've been searching the net for a day and the only stuff I can find is about autonumbers which does not apply here.
Related
I have a form (F_ptselect) with multiple subforms (F_s1, F_s2, F_s3). On the main form I have a combo box that allows me to choose an integer identifier (i.e., ID = 1001, id = 1002, id = 1003, id = 1004, etc.). The subforms are also all linked by ID using "Link Master Fields" and "Link Child Fields". I've found and modified vba that allows me to choose an ID (say 1001) from the combo box on F_ptselect, and subsequently pull up all the data for ID = 1001 on F_s1, F_s2, and F_s3.
Here's that vba:
Private Sub find_ID_AfterUpdate()
' Find the record that matches the control.
Dim rs As Object
Set rs = Me.Recordset.Clone
rs.FindFirst "[ID] = " & Me![find_ID] & ""
If Not rs.EOF Then Me.Bookmark = rs.Bookmark
End Sub
Now, for each ID there are multiple records (i.e., ID=1001 and day=1, ID=1001 and day=2, ID=1002 and day=1, ID=1002 and day=2 etc.). I'd like to be able to have a combo box or button or something that allows me to synchronize the ability to cycle through these records of a single ID. So if I select ID 1001 from the F_ptselect combo box, I'd like to see F_s1, F_s2, and F_s3 for ID 1001, day 1. Then I'd like to be able to change to day 2 for ID 1001 quickly using a combo box selection, button or something. Currently, I'd have to go to the record arrows at the bottom of each subform to change the record. Each row of data has a primary key (let's call it KEY) as well. So a query row or table row would look like:
KEY
ID
Day
1
1001
1
2
1001
2
3
1002
1
4
1002
2
Options:
RecordsetClone/Bookmark method for each subform
applied by Gustav sample Access db in https://www.experts-exchange.com/articles/18107/Synchronizing-Multiple-Subforms-in-Access.html?preview=cUa6D5QxDFA%3D
set each subform Filter and FilterOn properties
parameterized query as RecordSource for each subform
I always name subform container different from the form it holds, like ctrFS1. For option 2, consider:
Sub cbxDay_AfterUpdate()
Dim strF As String
With Me
strF = "[Day]=" & .cbxDay
.ctrFS1.Form.Filter = strF
.ctrFS1.Form.FilterOn = True
.ctrFS2.Form.Filter = strF
.ctrFS2.Form.FilterOn = True
.ctrFS3.Form.Filter = strF
.ctrFS3.Form.FilterOn = True
End With
End Sub
If you name each subform container like: ctrFS1, ctrFS2, ctrFS3, consider:
Dim x As Integer
With Me
For x = 1 to 3
.Controls("ctrFS" & x).Form.Filter = "Day=" & .cbxDay
.Controls("ctrFS" & x).Form.FilterOn = True
Next
End With
Here's the final code (based on the answer from June7) for any interested. The "Day" field is actually a string in my tables so that's why the concatenation syntax is for a string.
Private Sub find_day_AfterUpdate()
Dim strF1 As String
With Me
strF1 = "[Day]='" & .find_day & "'"
.F_s1.Form.Filter = strF1
.F_s1.Form.FilterOn = True
End With
Dim strF2 As String
With Me
strF2 = "[Day]='" & .find_day & "'"
.F_s2.Form.Filter = strF2
.F_s2.Form.FilterOn = True
End With
Dim strF3 As String
With Me
strF3 = "[Day]='" & .find_day & "'"
.F_s3.Form.Filter = strF3
.F_s3.Form.FilterOn = True
End With
End Sub
I connected the MS Access - Frontend with MySQL database using ODBC Connector.
There I have the tblCustomer and tblPayments. tblCustomer is linked with the tblPayments with the foreign key.
I had written the code to update the payment details of the respective customer.
For that, we have to update the existing recordset of the tblCustomer with the new payment entries.
Basically, Existing customers' payment information can be changed. In tblCustomer we have to Update the new payment details.
Suppose the old balance is $10. Now the person has paid the $10. So the current balance will be $0.
When I try to edit and update the new $0 balance to the tblCustomer it shows me
ODBC - inserting failed.
On Error GoTo Proc_Err
' variable for return from msgbox
Dim intRetValue As Integer
If Me.PaymentAmount = 0 Then
MsgBox "You must enter a payment amount or cancel the transaction.", vbOKOnly
Exit Sub
End If
If Me.txtPaymentVoucher < 1 Or IsNull(Me.txtPaymentVoucher) Then
MsgBox "You must enter a voucher number.", vbOKOnly
Me.txtPaymentVoucher.SetFocus
Exit Sub
End If
If Me.TransactionType = "Debit" Then
If Me.PaymentAmount > 0 Then
Me.PaymentAmount = Me.PaymentAmount * -1
End If
End If
If Me.PaymentReturnedIndicator Then
If Me.PaymentAmount > 0 Then
MsgBox "If this is a returned check enter a negative figure.", vbOKOnly
Me.PaymentAmount.SetFocus
End If
End If
If Me.PaymentCustomerID = 0 Then
Me.PaymentCustomerID = glngPaymentCustomerID
End If
If gbolNewItem Then
If Me.cboTransactionType = "Payment" Then
Me.txtLastPayment = Date
End If
End If
Me.txtCustomerBalance = (Me.txtCustomerBalance + mcurPayAmount - Me.PaymentAmount)
Me.txtPalletBalance = (Me.txtPalletBalance + mintPallets - Me.txtPallets)
Dim dbsEastern As DAO.Database
Dim rsCustomers As DAO.Recordset
Dim lngCustomerID As Long
Dim strCustomerID As String
Set dbs = CurrentDb()
Set rsCustomers = dbs.OpenRecordset("tblCustomers")
lngCustomerID = Me.PaymentCustomerID
strCustomerID = "CustomerID = " & lngCustomerID
rsCustomers.MoveFirst
rsCustomers.FindFirst strCustomerID
rsCustomers.Edit
rsCustomers!CustomerBalance = Me.txtCustomerBalance
rsCustomers!Pallets = Me.txtPalletBalance
rsCustomers!CustomerLastPaymentDate = Now()
rsCustomers.Update
rsCustomers.Close
Set rsCustomers = Nothing
FormSaveRecord Me
gbolNewItem = False
gbolNewRec = False
Me.cboPaymentSelect.Enabled = True
Me.cboPaymentSelect.SetFocus
Me.cboPaymentSelect.Requery
Me.fsubNavigation.Enabled = True
cmdNormalMode
Proc_Exit:
Exit Sub
Proc_Err:
gdatErrorDate = Now()
gintErrorNumber = Err.Number
gstrErrorDescription = Err.Description
gstrErrorModule = Me.Name
gstrErrorRoutine = "Sub cmdSaveRecord_Click"
gbolReturn = ErrorHandler() ' Display the error message
Resume Proc_Exit
End Sub
When rsCustomers.Update line executes then ODBC - insert failed error - 3146 occurs.
I checked that the error implies the datatype-Mismatch - code 13.
Then I changed the datatype of my table as well, but still not inserting the data.
While Andre showed you to the correct use of the FindFirst function, I find it pointless to open the whole customers table and then search for a single customer, when you can filter the recordset at point of creation to return only the customer you need.
lngCustomerID = Me.PaymentCustomerID
Set rsCustomers = dbs.OpenRecordset("SELECT * FROM tblCustomers WHERE CustomerID =" & lngCustomerID, dbOpenDynaset)
If rsCustomers.EOF Then
Debug.Print "Customer not found"
GoTo Proc_Exit
End If
'safe to update customer at this point
With rsCustomers
.Edit
'....
.Update
End With
You should then probably change rsCustomers to rsCustomer to make more sense.
After rs.FindFirst you must check with If rs.NoMatch Then if you actually found a record to edit.
Use this to find the underlying problem of error 3146 "ODBC-Call failed":
Determine real cause of ODBC failure (error 3146) with ms-access?
I want to fetch TOP N random records from the table but not more than 2 records for same name.
SELECT TOP 7 Table1.ID, Table1.Name, Table1.Salary, Rnd(Abs([Table1]![id])) AS Expr1
FROM Table1
GROUP BY Table1.ID, Table1.Name, Table1.Salary, Rnd(Abs([Table1]![id]))
ORDER BY Rnd(Abs([Table1]![id]));
It is giving more than two records for same name. Would someone please provide some assistance.
Use this query:
SELECT
ID,
[Name]
FROM
[Table1]
ORDER BY
Rnd(-Timer()*[ID]);
Then open it as a Recordset and traverse it from the start and pick IDs (could be saved in an array) while recording the the Name used (a Collection could be used for this).
If a Name has been used twice, skip the record and move to the next.
When you have picked seven IDs, stop. The array of IDs will identify your seven records.
Save the query as RandomAll. Then use it in this function:
Public Function RandomTwo() As long()
Dim rs As DAO.Recordset
Dim Names As New Collection
Dim Used As Integer
Dim Index As Integer
Dim Ids() As Long
Set rs = CurrentDb.OpenRecordset("RandomAll")
ReDim Ids(0)
Do While Not rs.EOF
Used = 0
' Read used count. Will fail if not used.
On Error Resume Next
Used = Val(Names.Item(rs.Fields(1).Value))
On Error GoTo 0
Debug.Print Used, ;
If Used = 1 Then
' Remove key to be added later with updated use count.
Names.Remove rs.Fields(1).Value
End If
If Used < 2 Then
' Record the use count (as text) of the key.
Names.Add CStr(Used + 1), rs.Fields(1).Value
Debug.Print rs!ID.Value, rs.Fields(1).Value
' Add ID to array.
Ids(UBound(Ids)) = rs!ID.Value
If UBound(Ids) = 6 Then
' Seven IDs found.
Exit Do
Else
' Prepare for next ID.
ReDim Preserve Ids(UBound(Ids) + 1)
End If
End If
rs.MoveNext
Loop
rs.Close
' List the found IDs.
For Index = LBound(Ids) To UBound(Ids)
Debug.Print Index, Ids(Index)
Next
' Return the IDs.
RandomTwo = Ids
End Function
The function will return the array holding the seven IDs.
Taking inspiration from Gustav's answer I have designed a bit of VBA code that will generate a SQL string which when used will give you N amount of random records with a limit of 2 per name.
Const PicksLimit As Long = 7 'How many records do you want to select
Dim rs As DAO.Recordset
'Select randomised table
Set rs = CurrentDb.OpenRecordset("SELECT ID, Name From Table1 ORDER BY Rnd(Abs(ID))")
'Define variables for keeping track of picked IDs
Dim Picks As Long, PickNames As String, PicksSQL As String
Picks = 0
PickNames = ""
PicksSQL = ""
With rs
If Not (.BOF And .EOF) Then 'If table is not empty...
.MoveFirst
'Loop until limit reached or table fully looked through
Do Until Picks = PicksLimit Or .EOF
'If name has been picked less than twice before
If Len(PickNames) - Len(Replace(PickNames, "[" & !Name & "]", "")) < ((Len(!Name) + 2) * 2) Then
Picks = Picks + 1 'Increment counter
PickNames = PickNames & "[" & !Name & "]" 'Add name for later checks
PicksSQL = PicksSQL & "ID = " & !Id & " OR " 'Append SQL string
End If
.MoveNext
Loop
'Add front sql section and remove last OR
PicksSQL = "SELECT * FROM Table1 WHERE " & Left(PicksSQL, Len(PicksSQL) - 4)
Else
'If the table is empty no need for ID checks
PicksSQL = "SELECT * FROM Table1"
End If
End With
rs.Close
Set rs = Nothing
'Print SQL String (This can be changed to set a RecordSource or similar
Debug.Print (PicksSQL)
At the moment the SQL string is just printed to the Immediate window but this can be changed to go wherever you need, like a subform's RecordSource for instance.
The code will need to be run every time you want a new random list but it shouldn't take a huge amount of time so I don't see that being too big an issue.
I am using VB6.0 for an assignment, it was so long that I used this. I'm trying to get the last inserted Id. My query is giving me the first row ID
I am using OLEDB. I have used some code but it is returning the first-row id.
Network
rec.Open "staff_profile", con, adOpenDynamic, adLockOptimistic
With rec
.AddNew
![fields] = values
.Save
'rec.Update
lastID = rec("ID")
FileCopy frmRegister.cdl.FileName, fname & transcode & ".jpg"
'return ID
MsgBox "Record Saved Successfully " & lastID, vbInformation, "Trillium"
I want the result to give me the last inserted id
Try with:
With rec
.AddNew
![fields] = values
.Save
.MoveLast
lastID = !ID.Value
End With
I have an append query that is trying to append some records to one of my tables. However, I am getting an error that says “didn’t add 1200 records due to key violations.” 1200 is the total number of records I am trying to append. I don’t understand why I am getting this error because all of my columns in the destination table allow duplicates (even though this append query doesn’t duplicate any information), and if I copy the structure of the table and append the records to that, everything works.
The problem seems to be that I am appending data to a table which already has existing data. Can someone please offer some suggestions for how I can work around this?
Thanks
Verify you haven't overlooked any unique indexes on your table. Save this procedure in a standard module and call it from the Immediate Window with the name of your destination table.
Public Sub InspectIndexes(ByVal pTable As String)
Dim db As DAO.Database
Dim i As Long
Dim j As Long
Dim strFields As String
Set db = CurrentDb
With db.TableDefs(pTable)
Debug.Print "Indexes.Count = "; .Indexes.Count
For i = 0 To (.Indexes.Count - 1)
With .Indexes(i)
Debug.Print i + 1 & ": Index Name = "; .name
If .Primary Then
Debug.Print vbTab & "Primary Key (Unique)"
Else
Debug.Print vbTab & "Unique: "; .Unique
End If
Debug.Print vbTab & "Fields.Count = "; .Fields.Count
strFields = vbNullString
For j = 0 To (.Fields.Count - 1)
strFields = strFields & "; " & .Fields(j).name
Next j
strFields = Mid(strFields, 3)
Debug.Print vbTab & "Fields: "; strFields
End With
Next i
End With
Set db = Nothing
End Sub
Here is sample output where tblFoo has 3 indexes: primary key (unique by definition) on id; a unique index on num_field1 and num_field2; and a non-unique index on parent_id.
InspectIndexes "tblfoo"
Indexes.Count = 3
1: Index Name = both_num_fields
Unique: True
Fields.Count = 2
Fields: num_field1; num_field2
2: Index Name = parent_id
Unique: False
Fields.Count = 1
Fields: parent_id
3: Index Name = pkey
Primary Key (Unique)
Fields.Count = 1
Fields: id