Round Robin Records in Access VBA - ms-access

I am attempting to round-robin names into a "TASK" column depending on which type of job is assigned in the "JOB" column. My table looks like this for example:
my code is as follows:
Sub macro2()
Dim Rst As DAO.Recordset
Set Rst = CurrentDb.OpenRecordset("table1")
Dim employee(2) As String
employee(0) = "empname1"
employee(1) = "empname2"
Dim i As Integer
With Rst
i = 0
Rst.MoveFirst
Do While Not .EOF
If Rst.Fields("JOB") = "LETTER" Then
Rst.Edit
Rst.Fields("Task").value = employee(i)
Rst.Update
End If
.MoveNext
i = i + 1
If i > 2 Then i = 0
Loop
End With
DoCmd.Requery
End Sub
The problem is, sometimes it "misses" an assignment, and I am not sure why.
It should have kept looping those 2 names into the column, but it wont. However, sometimes after running it a couple of times it will do it. Upon opening the DB fresh, it will not, and will appear as above after completing. Any ideas?

This piece of the code allows i to have a value of 2.
i = i + 1
If i > 2 Then i = 0
But UBound(employee) is 1, which means employee(i) should throw a "subscript out of range" error when i is 2. But you didn't report getting that error, so I don't understand what's going on.
Also your first screenshot shows "Letter" and "Change" in the Job column, but the second screenshot shows all as "Letter". That's another puzzler.
Maybe you need to load the recordset with a query rather than the full table.
Set Rst = CurrentDb.OpenRecordset("SELECT Job, Task FROM table1 " & _
"WHERE Job = 'Letter'")
Then as you move through the recordset rows, toggle i between 0 and 1.
i = IIf(i = 1, 0, 1)
It looks to me like those changes might allow your code to work as you intend. However consider an approach which is more flexible and easier to maintain. Store the employee names in a table and open a second recordset, rsEmployees, to hold those employee names. As you move through the first recordset, Rst, also advance the second: rsEmployees.MoveNext If you reach rsEmployees.EOF, do rsEmployees.MoveFirst That should "round robin" the assignments.
That approach would allow you to add/remove employees from the available pool by simply updating the employees table. You wouldn't need to revise your VBA code each time you add/remove employees.

Related

Inserting records in MS Access by means of macros

Good evening!
At this moment I'm learning to work in MS Access for my job purposes. I gained some understanding of the program's basics, such as creating tables or making easy forms (though not yet working ideally), and by now I've got stuck in solving the following task.
I have a database BooksDatabase, which consists of three tables: Books, Authors and AuthorsInfo. First one contains information about books (name, genre, country, release year etc.), third one is about authors (first name, last name etc.) and the second one links ever book with its author(s). The task is to import data from text file to those tables, so that it would be almost automatic. I understand how to import files to MS Access (at least, the ones of *.txt extension) and I do this into the table BooksToImport, but I have some difficulties with inserting imported data. Here is the code of my function ImportBooks(), which I execute from macros of the same name:
' Procedure which imports data about books from the table BooksToImport
Function ImportBooks()
Dim dbBooks As Database
Dim rstImBooks, rstBooks, rstAuthors, rstBALink As DAO.Recordset
Dim codeI, codeB, codeA, codeL As Variant
'initializing database
Set dbBooks = CurrentDb
Set rstImBooks = dbBooks.OpenRecordset("Query_BooksToImport",dbOpenDynaset) 'receiving data from query
'checking if the query has any records
If rstImBooks.RecordCount = 0 Then
MsgBox "There are no records for importing!", vbInformation, "Attention!"
rstImBooks.Close
Set dbBooks = Nothing
Exit Function
End If
'if it's OK, we're making a loop on query's records
rstBooks = dbBooks.OpenRecordset("Books",dbOpenDynaset)
rstAuthors = dbBooks.OpenRecordset("AuthorsInfo",dbOpenDynaset)
rstBALink = dbBoks.OpenRecordset("Authors",dbOpenDynaset)
rstImBooks.MoveLast
rstImBooks.MoveFirst
Do While rstImBooks.EOF = False
'checking if there is a book in out database with the same name as in imported data
codeB = DLookup("[ID]","[Books]","[BookName] = '" & rstImBooks![BookName] & "'")
If IsNull(codeB) Then
'inserting new record
With rstBooks
.AddNew
![BookName] = rstImBooks![BookName]
.Update
.Bookmark = .LastModified
codeB = ![ID]
End With
End If
'in much the same way we're treating the data about authors and making the links
rstImBooks.MoveNext
Loop
rstImBooks.Close
rstBooks.Close
rstAuthors.Close
rstBALink.Close
Set dbBooks = Nothing
End Function
I have two problems with this function:
method .AddNew for rstBooks is not working — MS Access shows me a message with error 438 ("Object doesn't support this property or method");
also I cannot assign variable rstBALink to the recordset because compiler says "Invalid use of property".
So my question is this: how should I solve these two problems? What do I do wrong that my function is not working properly?
A few issues with your code that I see. These may or may not fix your problem.
Your declarations are implicit, meaning you aren't being specific with your code about what your recordset objects are. Instead of using:
Dim rstImBooks, rstBooks, rstAuthors, rstBALink As DAO.Recordset
Try:
Dim rstImBooks As DAO.Recordset
Dim rstBooks As DAO.Recordset
Dim rstAuthors As DAO.Recordset
Dim rstBALink As DAO.Recordset
You can put them all on one line separated by commas, but you still need to declare the type for each or Access will assume it's a variant.
Secondly, recordset objects need to be created using the Set keyword, not by using an = alone.
This was done correctly in the top portion of your code, but is incorrect here:
rstBooks = dbBooks.OpenRecordset("Books",dbOpenDynaset)
rstAuthors = dbBooks.OpenRecordset("AuthorsInfo",dbOpenDynaset)
rstBALink = dbBoks.OpenRecordset("Authors",dbOpenDynaset)
Should be:
Set rstBooks = dbBooks.OpenRecordset("Books",dbOpenDynaset)
Set rstAuthors = dbBooks.OpenRecordset("AuthorsInfo",dbOpenDynaset)
Set rstBALink = dbBooks.OpenRecordset("Authors",dbOpenDynaset)
I think that will solve your issues, but I didn't review every line of your code admittedly. Let me know if you still have problems.
EDIT:
Found a typo:
rstBALink = dbBoks.OpenRecordset("Authors",dbOpenDynaset)
Should be:
Set rstBALink = dbBooks.OpenRecordset("Authors",dbOpenDynaset)
(missed an 'o' in dbBooks)

MS Access 2013 Web App - Create unique value for field between 0 and 9999

I have a table where I need the field "DirNum" to be a unique number between 0 and 9999. In addition, the user needs to be able to manually assign a "random" unique number to this field as long as it is between 0 and 9999 (such as the number 8000).
Since its not feasible to expect my user to guess unique numbers every time, I would like to have the ability to create this number for them. I'm pretty open as to how I should do this.
So what I have considered:
Make the default value this unique number
Make a control button
that inserts this unique number
Make the "New" control button
insert this new record
Problem is, I don't really know how to go about doing this.
I would assume the best way to do this would be to query all the existing values for "DirNum" and assign the lowest value to the new record. But I don't even know where to start when coding this.
You could make a function in vba to do this. This will return the next available id or 0 if none are available. The 9999 sets the upper limit.
Public Function getNextAvailableID() As Integer
Dim rst As DAO.Recordset
Set rst = CurrentDb.OpenRecordset("Select ID From TestUniqueNumber order by id", dbOpenSnapshot)
Dim intLastID As Integer
Dim intNextAvailableID As Integer
intLastID = 0
With rst
.MoveFirst
Do Until .EOF Or intLastID = 9999
If rst!ID - intLastID > 1 Then
intNextAvailableID = intLastID + 1
Exit Do
End If
intLastID = rst!ID
.MoveNext
Loop
End With
getNextAvailableID = intNextAvailableID
End Function
If you had many more rows than 9999 and vba was too slow, you could look into an SQL statement to handle this.

SQL Query is updated when user updates Excel

I have an excel document that I want to link to an SQL query. In the excel document I have a list of item numbers. Whenever an item number gets changed I want the sql query to query that list of item numbers and return an output. Basically I want the excel sheet to use the Item Number as a parameter for the database item numbers ? The excel item numbers are updated daily.
Keep in mind that this is a mock example for what you are trying to do. With no knowledge of your database or spreadsheet, I can't guarantee that any of this will even work. At the very least, it will require you to make some adjustments before you can use it.
With that in mind, I have commented on various parts of the code to let you know what is going on there. The sections that have a *** are areas that you may want to change. The sections with ### are areas that you will HAVE to change for it to work for you.
This code assumes that you have a list of item numbers in column A of sheet 1, that each item number will only return one record, and that there are no blank cells in your list of item numbers.
Sub GrabItemInfo()
Dim objADO As New ADODB.Connection
Dim objRecSet As New ADODB.Recordset
Dim objCmd As New ADODB.Command
Dim strConn As String
Dim strSQL As String
Dim RowNum As Long
Dim errNum As Long
'open a connection to the database
'### change the properties for the connection to suit your needs
strConn = "DSN=DSNName; DBQ=Database; UID=Username; PWD=Password"
objADO.Open strConn
objCmd.ActiveConnection = objADO
objCmd.CommandType = adCmdText
'errNum is the row that the error log will start on
'***change errNum to change which row it starts on
errNum = 1
'***changeRowNum here to change which row to start on
RowNum = 1
'start the loop
Do Until ThisWorkbook.Sheets(1).Cells(RowNum, 1) = ""
On Error Resume Next
'### change the sql to whatever you need
'*** change the cells section if you're not using the first column
strSQL = "SELECT [field] FROM [table] WHERE ItemNum = " & ThisWorkbook.Sheets(1).Cells(RowNum, 1).Value
objCmd.CommandText = strSQL
Set objRecSet = objCmd.Execute
'pastes results from query into the cell next to the item number
'***change the cells section if you want to use a different column
ThisWorkbook.Sheets(1).Cells(RowNum, 2).CopyFromRecordset objRecSet
'clear out the recordset before the loops starts again
Set objRecSet = Nothing
'put the item number, error number, and error description on the second sheet of the work book
'***change the sheet number to put it on another sheet if you're already using the second
If Err > 0 Then
ThisWorkbook.Sheets(2).Cells(errNum, 1).Value = ThisWorkbook.Sheets(1).Cells(RowNum, 1).Value
ThisWorkbook.Sheets(2).Cells(errNum, 2).Value = Err.Number
ThisWorkbook.Sheets(2).Cells(errNum, 3).Value = Err.Description
On Error GoTo 0
End If
'raise the value for the row for the next iteration
RowNum = RowNum + 1
Loop
'clear out the connection
Set objADO = Nothing
Set objRecSet = Nothing
Set objCmd = Nothing
End Sub
For more information on connection strings, I recommend http://www.connectionstrings.com
It's a great resource to use for figuring out what kind of connection string you need. Connections strings can be...tricky...sometimes, and this really helps.
If you need any resources for SQL, I would recommend http://www.w3schools.com/sql
They have a good introduction to it there. Past that, get a good reference book, find a mentor, join forums(or Q&A sites like this one), etc. If you look into the SQL tag on this site, there is more information, along with some recommended resources as well.
Good luck.

How to properly finish an access database transaction with DAO vba?

I'm working with DAO recorsets, the basic idea is to populate one table with records many times as the given argument indicates (limit).
It appears to work, but suddenly when I want to use the form again, it throws 3022 error. When I see table values, none of them is duplicated. I delete all records from that table and refresh table and form. The table doesn't show any value until I refresh the form. The unique value that is shown is the last value i try to save in database.
Here is a little bit of code:
Private Sub add_element(loops_number As Double)
i = 1
While (i < CDbl(loops_number))
function
i = i + 1
Wend
End Sub
That is working apparently fine.
Private Sub populate()
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim last As DAO.Recordset
Set db = CurrentDb()
Set rst = db.OpenRecordset("Element", dbOpenTable)
Set last = rst.Clone
With rst
.AddNew
If (last.RecordCount <= 0) Then
'here I pass input form values to recordset fields ,because its the first row
last.Close
.Update
.Close
Else
last.MoveLast
!Pk = Custom_pk 'Custom_pk is obtained with a function --- not relevant
'here I pass remain values from last record to a new one --- because records has the same attributes
last.Close
.Update
.Close
End If
Set rst = Nothing
Set ultimo = Nothing
End With
End Sub
It's like last record values stays "active" after function finish work. I don't get why this happens.
Element pk is alphanumeric e.g. : "A1", then I build a function that separates A from 1,add +1 to number and concatenate values again, so the result is "A2"
I resolved it using an Autonumber field as primary key keeping the original pk (alphanumeric) as a common field then I could mantain my vba code exactly like I wanted it.

Form hanging while running listbox query

My form is hanging for several seconds every time the user goes to a new record. The recordset for a listbox on the form is a query. The form is hanging until that query finishes and the listbox is populated.
My users need to be able to scroll through the records quickly. Currently, the user must wait for the listbox query to finish before moving to the next record. How can I stop the form from hanging?
Is there a way for DoEvents to be used to solve this problem?
Below is my code. I suspect that seeing all this code is not necessary, but I am sharing it all just in case.
I am using Access.
Thanks!
Option Compare Database 'Use database order for string comparisons
Option Explicit
Dim QuoteLogForm As Form
Public KeystrokeCount As Integer
'Define the similarity threshold for the matches list
Const SIMIL_THRESHOLD As Single = 0.83
Private m_strDialogResult As String
'The basis of this code was derived from http://www.accessmvp.com/tomvanstiphout/simil.htm
Private Sub Form_Current()
Matches
End Sub
Private Sub Matches()
'This sub calls the functions necessary to generate a query that lists
'the KFC RFQ #'s whose similarity exceeds the threashold, as defined above.
Dim sql As String
Dim strOpenArgs As String
Dim strInClause As String
'OpenArgs contains the part # to find similars for.
strOpenArgs = Replace(Replace(Nz(Me.Part_Number_Textbox.Value), "-", ""), " ", "") 'Nz changes Nulls to blanks
'Call the GetSimilarPartNos function below.
'This function returns a string of KFC RFQ #'s that exceed the threashold, wrapped in single quotes and separated by commas.
strInClause = GetSimilarPartNos(strOpenArgs)
'If any similar part numbers were found, run a query to select all the listed records
If VBA.Len(strInClause) > 0 Then
'Select records whose KFC RFQ #'s are found in the strInClause list, sort from most to least similar
sql = "select * from [Matches List Query] where [KFC RFQ #] in (" & strInClause & ")" ' order by SimilPct desc, DateShort desc"
'[Forms]![Price Form Parent]![Price Form].[Form].Customer_Filter_Box
Set Me.[Matches List Form].Form.Recordset = CurrentDb.OpenRecordset(sql, dbOpenSnapshot)
Else
'If no similar KFC RFQ #'s were found, select no records
sql = "select * from [Matches List Query] where 1 = 0"
Set Me.[Matches List Form].Form.Recordset = CurrentDb.OpenRecordset(sql, dbOpenSnapshot)
End If
End Sub
Private Function GetSimilarPartNos(ByVal strPartNo As String) As String
'The GetSimilarPartNos function calls the fnSimil function and compiles a list (strInClause)
'of KFC RFQ #'s whose part numbers exceed the threashold
Dim rs As DAO.Recordset
Dim strInClause As String
Dim sngSimil As Single
'Erase all previous values in the [Quote Log].Simil field
CurrentDb.Execute "update [Quote Log] set Simil = 0", dbFailOnError
Set rs = CurrentDb.OpenRecordset("Quote Log") ', dbOpenTable)
'Loop to calculate the similarity of all part numbers
While Not rs.EOF 'Loop until the end
Dim curPartNo As String
curPartNo = Replace(Replace(Nz(rs![Part #]), "-", ""), " ", "")
If rs![KFC RFQ #] = Me.[KFC RFQ #] Then
GoTo 120
End If
sngSimil = fnSimil(curPartNo, strPartNo)
'If the part number similarity value of a single record is greater than the
'threashold (as defined above), add the record's KFC RFQ # to strInClause
'strInClause forms a list of KFC RFQ #'s whose part numbers exceed the threashold
'in similarity, wrapped in single quotes and separated by commas
If sngSimil >= SIMIL_THRESHOLD Then
strInClause = strInClause & "'" & rs![KFC RFQ #] & "',"
'Show the Simil value on this form
rs.Edit
rs!Simil = sngSimil
rs.Update
End If
120 rs.MoveNext
Wend
rs.Close
Set rs = Nothing
'Once the strInClause is completed, remove the last comma from the list
If Len(strInClause) > 0 Then strInClause = VBA.Left$(strInClause, Len(strInClause) - 1)
GetSimilarPartNos = strInClause
End Function
The UI is hanging because the work is being done by the UI thread. If you want (or need) a more responsive application, you need to offload the work to a background thread. As far as I know, for VBA, that is not something for the feint of heart, but you can take a look, VBA + Threads in MS Access.
As access is a database, it suffers from all the drawbacks of any database, mainly finding data stored on slow, usually spinning, media. I suggest you take a look at this article: Create and use an index to improve performance to help you create efficient indexes for your queries, if you have not indexed for them already. You also need to consider the performance implications of WHERE, JOIN, and ORDER BY clauses in your queries. Make sure your indexes are optimized for your queries and your data is stored in a logical fashion for the way it will be queries out. Beyond that, if the database does not reside on the machine from which the queries are being executed, you have network I/O latency on top of expected Disk I/O latency. This can significantly impact the read performance of the database.
I think you might possibly have the wrong form event.
The form_Current event fires between each record and I can't imagine that's what you really need. Try moving your "Matches" routine into the OnLoad event instead.