I have an Access database with about 500,000 records. There is a specific column which has the transaction reference.
This is of the form:
Transaction_Ref
CDY1053N1
CDY1053N2
CDY1053N3
JFD215D1
JFD215D2
Where CDY1053N and JFD215D are customer references, and the 1,2,3, etc which follows is the transaction number.
What I am looking for is a loop which will update a column called "Group". This will go to row 1, and loop through the database to find transaction references similar to CDY1053N and assign a group ID, for example:
Transaction_Ref Group_ID
CDY1053N1 1
CDY1053N2 1
CDY1053N3 1
JFD215D1 2
JFD215D2 2
Any ideas please?
Thanks for the help.
This might not be the best or most elegant way to do this (particularly with the number of records you have), but this worked on my small set of test records.
I've assumed Transaction_Ref and Group_ID are in the same table and I've called that table tblTransactions.
I've also assumed that you might want to run this on new data so have nulled the Group_ID before looping through and resetting the values. This could mean that a different value for Group_ID gets assigned for a group of records (for example, were your records change order between subsequent runs of this sub).
If that's a problem you'll need to tweak this a bit.
Public Sub AssignGroupID()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim sql As String
Dim i As Integer
Set db = CurrentDb
' Clear the Group_ID column (in case you want to run this more than once)
sql = "UPDATE tblTransactions Set Group_ID = Null"
db.Execute sql
' Open your table with the Transaction_Ref and Group_ID fields
Set rs = db.OpenRecordset("tblTransactions")
' Zero the counter
i = 0
' Start the loop (set it to end when it gets to the last record)
Do While Not rs.EOF
' Only update Group_IDs that haven't got a value yet
If IsNull(rs!Group_ID) Then
' Push the counter on
i = i + 1
' Update all Group_IDs with current counter number that
' match the customer reference of the current record
sql = "UPDATE tbltransactions Set Group_ID = " & i & " WHERE " _
& "Left(tblTransactions.Transaction_Ref, Len(tblTransactions.Transaction_Ref) -1) = '" _
& Left(rs!Transaction_Ref, Len(rs!Transaction_Ref) - 1) & "'"
db.Execute sql
End If
' Move to the next record
rs.MoveNext
Loop
'clean up
rs.Close
Set rs = Nothing
Set db = Nothing
End Sub
Related
I have quite a conundrum which I have been trying to troubleshoot. I have a stored procedure in a MySql database, which I call through an Excel VBA application. The VBA application passes the recordset into an Array, and then I use a For Loop to place each of the items in the Array onto a worksheet.
Here's the problem: two of the values in the recordset keep coming back blank in Excel. Oddly, the two are in the middle of the Array, not the beginning or end. However, if I call the stored procedure through another query program such as HeidiSql, I receive ALL values back. I'm at a loss as to why I'm not receiving all of the values through Excel... or why the Array isn't receiving them all, at any rate.
Thanks in advance for your help.
Here is my code:
Sub StartHereFlexFunderCust()
On Error GoTo ErrorHandler
Dim Password As String
Dim SQLStr As String
'OMIT Dim Cn statement. Cn stands for Database Connection
Dim Server_Name As String
Dim User_ID As String
Dim Database_Name As String
Dim custID As String
Dim myArray()
'OMIT Dim rs statement. rs stands for Database Recordset and is the Recordset of what is returned
Set RS = CreateObject("ADODB.Recordset")
Server_Name = Range("O10").Value
Database_Name = Range("O11").Value ' Name of database
'id user or username. We need to write code to insert the current user into this variable (Application.Username) if possible. But they may not be consistent across all machines.
'For example mine is "Ryan Willging" and we would have to shorten it to rwillging but others may be rwillging.
'This is important because if we do not do this all queries will come from the same person and that is not good for debugging.
User_ID = Range("O12").Value
Password = Range("O13").Value
custID = Range("C4").Value 'Deal Number from Start here that we are passing into the stored procedure
'This is the storedprocedure call and it passes in the value of the DealId to the Stored Procedure
SQLStr = "call flexFundByCustomer(" + custID + ")"
Set cn = CreateObject("ADODB.Connection") 'NEW STATEMENT
'This statement takes the variables from the checklist and passes them into a connection string
cn.Open "Driver={MySQL ODBC 5.1 Driver};Server=" & _
Server_Name & ";Database=" & Database_Name & _
";Uid=" & User_ID & ";Pwd=" & Password & ";"
'This statement queries the database using the SQL string and the connection string.
'The adOpenStatic variable returns a static copy of a set of records that you can use to find data or generate reports. There are other variables that
'could be used but I think this one will suffice.
RS.Open SQLStr, cn, adOpenForwardOnly
Debug.Print msg 'or MsgBox msg
'Take all of the info from the queries and put them into the spreadsheet
myArray = RS.getrows()
Dim Fld_Name As String
Dim Val_of_Field As String
Dim starthere As Worksheet
Fld_Name = UBound(myArray, 1)
Val_of_Field = UBound(myArray, 2)
Set starthere = ThisWorkbook.Sheets("Start Here")
MsgBox "No error yet defined Start Here!"
'This little loop works well to dump the recordset into excel. We can then map the correct fields 'k inputs the headers and R inputs the rows returned in the Recordset
For K = 0 To Fld_Name ' By using a For loop the data is inputed into excel one row at a time
starthere.Range("U4").Offset(0, K).Value = RS.fields(K).Name
For R = 0 To Val_of_Field
starthere.Range("U4").Offset(R + 1, K).Value = myArray(K, R)
Next
Next
RS.Close
Set RS = Nothing
cn.Close
Set cn = Nothing
ErrorHandler:
MsgBox "There's been an error!"
Exit Sub
End Sub
Consider using Range.CopyFromRecordset method to avoid any use of arrays. Or if memory does not allow, use a Do While Loop across Recordset columns:
' COLUMN HEADERS
For i = 1 To RS.Fields.Count
starthere.("Results").Range("U4").Offset(0, i) = RS.Fields(i - 1).Name
Next i
' DATA ROWS
' COPYFROMRECORDSET APPROACH
starthere.Range("U5").CopyFromRecordset RS
' DO WHILE LOOP APPROACH
starthere.Activate
starthere.Range("U5").Activate
row = 5
Do While Not RS.EOF
For i = 0 To RS.Fields.Count - 1
ActiveCell.Offset(0, i) = RS.Fields(i)
Next i
row = row + 1
ActiveCell.Offset(row, 21)
RS.MoveNext
Loop
As for the values returning empty that may be a MySQL and Excel incompatibility of data types. For instance, you may have a table field set to MySQL's maximum decimal (65, 30) which denotes max digits of 65 and max 30 decimal points which cannot be reflected on a spreadsheet. Current precision limit of a cell value is 15 decimal points.
Alternatively, you may have a VARCHAR(65535) which is the 65,535 byte limit or the open-ended TEXT column of no limit that also cannot be displayed on spreadsheet. Current limit of characters in one cell is 32,767.
Try modifiying column to a smaller type:
ALTER TABLE `tableName` MODIFY COLUMN `largenumberfield` DECIMAL(10,7);
ALTER TABLE `tableName` MODIFY COLUMN `largetextfield` VARCHAR(255);
Why the other programs such as HeidiSQL retrieve values? It might be due to their internal conversion features forcing data values into a specific format (i.e., removing whitespaces, truncating values) which then renders adequately in Excel.
I have created below piece of code in order to amend some data in an Access table:
Dim Ways As DAO.Recordset
Dim Keys As DAO.Recordset
Dim Recordcount As Double
Dim Records As Double
Dim ID_Old As String
Dim ID_New As String
Dim STArray() As String
Dim SaveTime As String
Set Ways = CurrentDb.OpenRecordset("Ways_Sorted")
Recordcount = 1
Records = 3724755
Ways.MoveFirst
Dim word As Variant
While Not Ways.EOF
DoCmd.SetWarnings (False)
DoCmd.OpenQuery "KeyFind:DEL"
DoCmd.SetWarnings (True)
Set Keys = CurrentDb.OpenRecordset("KeyFind")
STArray = Split(Ways!Veld4, ";")
For Each word In STArray
If Len(word) > 0 Then
Keys.AddNew
Keys!IDOld = CDbl(word)
Keys!IDNew = DLookup("[New ID]", "ID Keys", "[Old ID]=" & CDbl(word))
Keys.Update
End If
Next
Keys.MoveFirst
While Not Keys.EOF
ID_Old = " " + Trim(Str$(Keys!IDOld))
ID_New = " " + Trim(Str$(Keys!IDNew))
Ways.Edit
Ways!Veld4 = Replace(Ways!Veld4, ID_Old, ID_New)
Keys.MoveNext
Wend
Keys.Close
Me.Tekst1 = Recordcount
Me.Tekst3 = Records - Recordcount
Me.Tekst5 = FileLen(Application.CurrentProject.Path & "\Map_Convert_2.mdb")
If FileLen(Application.CurrentProject.Path & "\Map_Convert_2.mdb") > 1977142784 Then
' Exit Sub
End If
DoEvents
Ways!Done = True
Ways.Update
Ways.MoveNext
Recordcount = Recordcount + 1
'CommandBars("Menu Bar").Controls("Tools").Controls("Database utilities").Controls("Compact and repair database...").accDoDefaultAction
'Stop
Wend
DoCmd.SetWarnings (False)
DoCmd.OpenQuery "Ways_Amend ID"
DoCmd.SetWarnings (True)
MsgBox "New Map created"
Actually what the code is doing is replacing the data in field "Veld4" in table "Ways_Sorted". This field holds a string with ID's, which is splitted with STArray = Split(Ways!Veld4, ";") into an array.
This array is stored in a table called "KeysFound".
Another table in my database is containing the old ID and the new ID.
As said the rest of the code will replace the old id in "Veld4"with the new ID.
It is looping through 3.7 million records this way.
My problem is that after 250 loops or so my database has grown with 1mB, meaning that my database will be above the 2gB way before the code has finished.
I can not explain why the growth is happening and how I can stop this or at leas reduce the growth
Your code has lots of potential for optimization.
Main issue: you are constantly writing into and deleting from the Keys table. I guess this is also the cause of the growth issue.
This table is unnecessary. Just do the replacement right after reading each key. Build the new Veld4 as string NewVeld, only write it into the table once you are finished for the current Ways row.
STArray = Split(Ways!Veld4, ";")
NewVeld = ""
For Each word In STArray
If Len(word) > 0 Then
NewKey = DLookup("[New ID]", "ID Keys", "[Old ID]=" & CDbl(word))
' you will have to adapt this to your exact "veld" structure
' If there is a specific reason, you can also continue to use Replace(),
' but I don't think it's necessary.
NewVeld = NewVeld & ";" & NewKey
End If
Next
' remove leading ";"
NewVeld = Mid(NewVeld, 2)
Ways.Edit
Ways!Veld4 = NewVeld
Ways!Done = True
Ways.Update
Ways.MoveNext
Further optimization: DLookup is a rather expensive operation for your row count.
Consider loading the whole ID Keys table into a Dictionary object at the beginning, then reading the new IDs from there.
I am trying to accomplish the following:
Use VBA to loop through a table, and assign people to be seated at dinner tables using the following three parameters:
1) The individual's priority score.
2) The individual's preferences on what table to be seated at.
3) The seating capacity of the table.
Ideally, the VBA would start from the 1st record of Priority 1 group, assign as many people as can be placed in Table1, and then continue assigning Priority 1 individuals according to their preference, while checking to see if their preferred tables are at capacity.
After all Priority 1 individuals are assigned a table (given a 'Table_Assignment' value in the table object), the VBA moves to Priority 2 individuals, and so forth.
In my database, I have the following table (table object called 'tbl_Assignments'):
RecordID | Table_Assignment | Priority | Title | Preference_1 | Preference_2 |... Preference_n
001 1 CEO Table1
002 1 CEO-spouse Table1
003 1 VP Table1 Table2
004 1 VP-spouse Table1 Table2
005 2 AVP Table1 Table2
006 2 AVP-spouse Table1 Table2
007 3 Chief counsel Table1 Table2 Table_n
008 3 COO Table1 Table2 Table_n
Additionally, I have created a query tells you how many vacancies are left as assignments to tables are being made (query object called 'qry_capacity_sub1'):
TableID | Maximum_seating | Seats_taken | Vacancies
Table1 4 3 1
Table2 4 2 2
Table3 4 0 4
Table4 4 1 3
I have attempted to write VBA, with a loop, that would accomplish my goal of looping through the table ('tbl_Assignments') and assigning values for the 'Table_Assignment' field once a command button is clicked on a form.
Update (11/09/2014): Updated the VBA to where I am in this process now. The changes to the VBA also reflect Jérôme Teisseire's suggestion.
The following VBA started from what I saw here: Looping Through Table, Changing Field Values
Private Sub Command0_Click()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strSQL As String
Set db = CurrentDb()
strSQL = "Select RecordID, Table_Assignment, Priority, Preference_1, Preference_2, Preference_3 FROM tbl_Assignments WHERE Priority =1"
Set rs = db.OpenRecordset(strSQL)
On Error GoTo Err_Handler
Do Until rs.EOF
With rs
If there are seats available at your first preferred table Then
.Edit
!Table_Assignment = rs!Preference_1
.Update
.MoveNext
End If
If the first table you preferred has reached capacity, and there are seats left in your second preferred table Then
.Edit
!Table_Assignment = rs!Preference_2
.Update
.MoveNext
End If
'..keep checking each the person's preferred tables. If they cannot be assigned a table because their preferred tables are at capacity...
Else
.Edit
!Table_Assignment = "Unassigned"
.Update
.MoveNext
End With
Loop
rs.Close
Exit_Handler:
Set rs = Nothing
Set db = Nothing
Exit Sub
Err_Handler:
MsgBox "You need to debug"
Resume Exit_Handler
End Sub
Probably qry_capacity_sub1 relies on tbl_Assignments and when you're trying to query and update it at the same time it makes access crash.. To verify this you try to replace your DLookup conditions with some fake checks like
If True Then
...
just to verify that the rest of the code works properly.
Also I think there is another logical mistake in your code in DLookup conditions - "TableID='Preference_1'" will search for a 'Preference_1' string but not the column value. I think it must be something liek "TableID='" + rs!Preference_1 + "'", but I afraid this will not help as well.
I'd suggest you to cache vacancies per table into in-memory dictionary and decrement vacancy each time you assign the table. So the code could be something like the given below. Also note that it is better not to nest MoveNext in any If to be sure that there will be no endless loop (this could be also the cause of the crash).
Private Sub Command0_Click()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strSQL As String
Dim VacancyPerTable As New Scripting.dictionary
Set db = CurrentDb()
Set rsVac = db.OpenRecordset("SELECT DISTINCT TableID, Vacancies FROM qry_capacity_sub1")
While Not rsVac.EOF
VacancyPerTable.Add rsVac!TableID, rsVac!Vacancies
Loop
rsVac.Close
strSQL = "Select RecordID, Table_Assignment, Priority, Preference_1, Preference_2, Preference_3 FROM tbl_Assignments WHERE Priority =1"
Set rs = db.OpenRecordset(strSQL)
On Error GoTo Err_Handler
Do Until rs.EOF
With rs
If VacancyPerTable(!Preference_1) > 0 Then
.Edit
!Table_Assignment = rs.Fields(3)
.Update
VacancyPerTable(!Preference_1) = VacancyPerTable(!Preference_1) - 1
ElseIf VacancyPerTable(!Preference_2) > 0 Then
.Edit
!Table_Assignment = rs.Fields(4)
.Update
VacancyPerTable(!Preference_2) = VacancyPerTable(!Preference_2) - 1
ElseIf VacancyPerTable(!Preference_3) > 0 Then
.Edit
!Table_Assignment = rs.Fields(5)
.Update
VacancyPerTable(!Preference_3) = VacancyPerTable(!Preference_3) - 1
Else
.Edit
!Table_Assignment = "UnAssigned"
.Update
End If
.MoveNext
End With
Loop
rs.Close
Exit_Handler:
Set rs = Nothing
Set db = Nothing
Exit Sub
Err_Handler:
MsgBox "You need to debug"
Resume Exit_Handler
End Sub
you don't test null value for DLookup , so you must have an inifinity loop,
some call to .MoveNext missing and you never have rs.EOF equal true
change your code in:
Do Until rs.EOF
With rs
If (DLookup("Vacancies", "qry_capacitycheck", "Dinner_Tbl_Name='Table1'")) > 0 Then
.Edit
!Table_Assignment = Table1
.Update
.MoveNext
else
.Edit
!Table_Assignment = "UnAssigned"
.Update
.MoveNext
End If
End With
Loop
I need some help with some VBA for Access.
I have a table "Client_Table" with 100 rows of data. I have another table "SalesRep_Table" where I have 10 distinct Sales Rep ID numbers (such as: AA1111, and so on).
My goal is to run a procedure that takes the first ID record "AA1111" and places it in the appropriate column on the Clients table named "AssignedSalesRepID" for the first 10 rows, then the next ID number in the SalesRep_Table gets inserted into the next 10 cells in the Clients table, and the process repeats through a loop until all 10 IDs are now in 10 rows each to fill the 100 rows of data in the Clients table.
I went about it by creating two recordsets and trying a loop through SQL Update. However I end up with all 100 records containing just the last Sales Rep ID 100 times repeating. Can you take a look at my code and let me know where it needs to be fixed?
Public Sub Command01_Click()
Dim strSQL
Dim ClientsTableQuery, SalesRepList
Dim DataB as Database
Dim ClientQD as QueryDef
Dim SalesQD as QueryDef
Dim rstClient as Recordset
Dim rstSalesRep as Recordset
ClientTableQuery = "Clients"
SalesTableQuery = "SalesRepList"
'Creates a recordset with 100 client records named "Clients"
strSQL = "Select * from Client_Table"
Set DataB = CurrentDB()
Set ClientQD.CreateQueryDef(ClientTableQuery, strSQL)
Set rstClient = DataB.OpenRecordset(ClientTableQuery)
'Creates a recordset with 10 sales rep records named "SalesRepList"
strSQL = "Select SalesRepID from SalesRep_Table"
Set DataB = CurrentDB()
Set SalesQD.CreateQueryDef(SalesTableQuery, strSQL)
Set rstSalesRep = DataB.OpenRecordset(SalesTableQuery)
rstSalesRep.MoveFirst
rstClient.MoveFirst
Do Until rstSalesRep.EOF = True
'SQL Query to update the top 10 cells in the "Assigned Sales Rep ID" column in the
Clients recordset with the Sales Rep ID from the SalesRepList recordset
strSQL = "Update Clients, SalesRepList SET Clients.AssignedSalesRepID =
SalesRepList.SalesRepID where Clients.ClientIDNumber in (Select Top 10
Clients.ClientIDNumber FROM Clents where Clients.AssignedSalesRepID is Null)"
DoCmd.RunSQL (strSQL)
rstSalesRep.MoveNext
Loop
MsgBox "Finished Looping"
rstSalesRep.Close
End Sub
I hate to be the one to tell you this, but you should reconsider using SQL to do this update. I see that you have already written a lot of code and might feel like if you switch back to SQL that you will then have wasted all this vb code. I have felt like that myself in times past. But you can solve this problem with SQL with an order of magnitude less code(or nearly so).
Steps for SQL solution:
Sequence rows in both sets
mod A set sequence by B set sequence max
update A set on mod = b seq
You are making a Join call in your query, without defining how those 2 tables are being joined. You are not mentioning anywhere, which record of the rstSalesRep recordset you wish to set the assignedSalesRepId to.
Also I would reduce all your code down to the following:
Dim strSQL
Dim DataB As Database
Dim rstSalesRep As Recordset
Set DataB = CurrentDb()
Set rstSalesRep = DataB.OpenRecordset("Select SalesRepID from SalesRep_Table ")
Do Until rstSalesRep.EOF = True
strSQL = "Update Client_Table, SalesRep_Table SET Client_Table.AssignedSalesRepID = SalesRep_Table.SalesRepID " & _
"where Client_Table.ClientIDNumber in (Select Top 2 Client_Table.ClientIDNumber FROM Client_Table where Client_Table.AssignedSalesRepID is Null)" & _
" and SalesRep_Table.SalesRepID = '" & rstSalesRep("SalesRepID") & "'"
DoCmd.RunSQL (strSQL)
rstSalesRep.MoveNext
Loop
MsgBox "Finished Looping"
rstSalesRep.Close
In a SQL database I have a table, Table1. This table is related to another table, Table2 which in turn is related to Table3. There is a query Query1 that selects certain records from Table1.
This database is linked to in an Access database project
A form Table1Data is based on Table1, with a datasheet containing related Table2 data (and subsequently Table3 data). This form is opened by another form (Switchboard). The problem comes when the form is opened. I want the form to be filtered, but when I set up a macro and open the form and set the Filter to Query1, the data in the form is not filtered. Why does this happen, is this not the way to do it? Query1 selects all the columns from Table1, so mismatching columns should not be an issue.
Additionally I want to lock it down - only certain people can execute Query1, same with other queries (Query2, Query3 etc). So they can only edit the data that they are permitted to edit.
My preferred solution is to set the recordsource in the Form Open event. This gives me the most control over what is going on.
Here is my boilerplate for doing this. It also includes looking up the OpenArgs which are passed on calling the form. You can just comment out or remove the If/Then statement if you aren't looking to specify anything from the calling form in your SQL.
Private Sub Form_Open(Cancel As Integer)
' Comments :
' Parameters: Cancel -
' Modified :
' --------------------------------------------------
On Error GoTo Err_Form_Open
Dim strSQL As String
Dim strVariable As String
Dim strDateVariable As String
Dim dteDateVariable As String
Dim i As Integer
Dim n As Integer
'Get variables from Left and right of | in OpenArgs
If Not (IsNull(Me.OpenArgs)) Then
i = InStr(1, Me.OpenArgs, "|")
n = Len(Me.OpenArgs)
strVariable = Left(Me.OpenArgs, n - (n - i + 1))
strDateVariable = Right(Me.OpenArgs, (n - i))
dteDateVariable = CDate(strDateVariable)
Else
GoTo Exit_Form_Open
End If
strSQL = "SELECT ... " _
& "FROM ... " _
& "WHERE (((Field1)='" & strVariable & "') " _
& " AND ((Field2)=#" & dteDateVariable & "#));"
Me.RecordSource = strSQL
Me.Requery
Exit_Form_Open:
Exit Sub
Err_Form_Open:
Select Case Err.Number
Case Else
Call ErrorLog(Err.Number, Err.Description, "Form_Open", "frmName", Erl)
GoTo Exit_Form_Open
End Select
End Sub