Repetition of query to produce report - ms-access

I am creating a bill of materials program.
There are two main tables named Products and Sub_Products.
In the Products table, the fields are (Product_Name, Code).
In the Sub_Products table, the fields are (Code, Sub_Name).
The tables are linked with code, i.e.: one product is made up of many sub_products, each sub_product is a product as well, making it have many sub_products.
I have created a query that reads a product and gets its sub_products. I need a query to compare Sub_Name with Product_Name and then check more sub_products,
continuing until no more sub_products are found.
Any ideas?

I guess you will have to use a script rather than SQL query to loop through them. Assuming that the products can be nested more than 3 levels.

I've been working on this exact problem in an ASP.NET MVC application. A function that gathered all the subproducts for each product and recursed on each subproduct worked well. We have some BOMs that are 15 levels deep.

I realize this question was asked a long time ago, but I had a very similar question and finally figured out a good answer. So I am posting it here in case anyone needs to know how to create a Bill of Materials.
In my example there is a table called "Part_Item_Table" which lists parent items and all of their childeren. Those childeren can also be parents to other childeren. The difficulty was that the BOM could be 3 levels deep all the way up to 30 levels deep or more. My "Part_Item_Table" also lists whether items are "Make" items or not. Only "Make" items will have childeren. The table you are querying may not have that feature, but the code below will probably still be helpful to get the idea.
This set of code uses several things that were new to me such as recursive code, calling a query I had already created and passing in a variable using the querydef methods, and using recordsets to get large information sets in and out of functions. I also used a sequence field in my BOM Table so I could sort by it and view the BOM in the order it is meant to be (Showing visually which level 3 items roll up into which level 2 items). If there is something that can be improved I am open to suggestions. This does work for my needs right now and hopefully it is helpful to someone else.
Option Compare Database
Public stFirstPart As String
Private Const BOMTable As String = "BOM_Table" 'Set this variable to the name of the table
Private Const ComponentQ As String = "GetComponentsQ" 'Set to the name of the query in the database
Function BOM()
Dim stQuery As String 'Used to make a query
Dim i As Integer 'Used to create the sequence number
Dim iLevel As Integer 'Used to show BOM level
Dim rsParent, rsBOMTable As DAO.Recordset 'Used to hold query results
'Make sure there is a part number in the form
If IsNull(Forms![Entry Form]![Part_Number]) Then
Debug.Print "There is no part number entered in the form"
MsgBox "There is no part number in the form.", vbOKOnly, "Can't fool me."
Exit Function
End If
stFirstPart = Forms![Entry Form]![Part_Number] 'Get the top part number from the form
'Make sure this is a Make item. Only make items will have childeren
stQuery = "SELECT ITEM.ITEM_NO, ITEM.MAKE_BUY_FLAG, ITEM.CURRENT_FLAG " & _
" FROM PART_ITEM_TABLE AS ITEM " & _
" WHERE (((ITEM.ITEM_NO)='" & stFirstPart & "') AND ((ITEM.MAKE_BUY_FLAG)='M') AND ((ITEM.CURRENT_FLAG)='Y'));"
Set rsParent = CurrentDb.OpenRecordset(stQuery)
If rsParent.EOF And rsParent.BOF Then
Debug.Print "This is not a make item"
MsgBox "This is not a Make item.", vbOKOnly, "I tried."
Exit Function
End If
'Clear the BOM table and load this first part number
DoCmd.SetWarnings False
DoCmd.RunSQL "Delete from " & BOMTable & ""
Set rsBOMTable = CurrentDb.OpenRecordset(BOMTable, dbOpenDynaset)
i = 1
iLevel = 1
rsParent.MoveFirst
With rsBOMTable
.AddNew
!Sequence = i
!Level = iLevel
!Item_Number = stFirstPart
!Make_Buy = "M"
.Update
End With
rsParent.Close
Set rsParent = Nothing
rsBOMTable.Close
Set rsBOMTable = Nothing
'-----------------------------------------------------------------------------------------------------------------------------------
'Start going down levels
'-----------------------------------------------------------------------------------------------------------------------------------
iLevel = 2
Call RecursiveLevels(stFirstPart, iLevel, i)
DoCmd.SetWarnings True
End Function
Function RecursiveLevels(PartNumber As String, iLevel As Integer, i As Integer)
Dim rsLevels As DAO.Recordset
Dim stPart As String
Set rsLevels = GetComponents(PartNumber)
If rsLevels.BOF And rsLevels.EOF Then
Debug.Print "This was a Make item with no children. That shouldn't happen. "; PartNumber
GoTo ExitPoint
End If
rsLevels.MoveFirst
Do While Not rsLevels.EOF
If rsLevels!Make_Buy <> "M" Then ' Anything that is not a Make item is written to the BOM table one line at a time.
i = i + 1
Call WriteToBOMTable(iLevel, i, rsLevels!Parent_Number, rsLevels!Component_Number, rsLevels!Make_Buy)
Else 'The Make item is written to the table, then we query for all of its children
stPart = rsLevels!Component_Number
i = i + 1
Call WriteToBOMTable(iLevel, i, rsLevels!Parent_Number, rsLevels!Component_Number, rsLevels!Make_Buy)
If stPart = stFirstPart Then 'Check to make sure this recursive thing doesn't go on forever.
Debug.Print "This part number is the same as the first part number. Circ Reference. "; stPart
GoTo ExitPoint
End If
iLevel = iLevel + 1 ' get ready to go one level deeper
Call RecursiveLevels(stPart, iLevel, i)
End If
rsLevels.MoveNext
Loop
ExitPoint:
iLevel = iLevel - 1 'Done with this level. Come back up a level.
rsLevels.Close
Set rsLevels = Nothing
End Function
Function WriteToBOMTable(Level As Integer, i As Integer, ParentNumber As String, ComponentNumber As String, MakeBuy As String)
Dim rsBOMTable As DAO.Recordset
Set rsBOMTable = CurrentDb.OpenRecordset(BOMTable, dbOpenDynaset)
With rsBOMTable
.AddNew
!Parent_Number = ParentNumber
!Item_Number = ComponentNumber
!Level = Level
!Make_Buy = MakeBuy
!Sequence = i
.Update
End With
Debug.Print "Level: "; Level; "Component: "; ComponentNumber
rsBOMTable.Close
Set rsBOMTable = Nothing
End Function
Function GetComponents(PartNumber As String) As DAO.Recordset
Dim qdf As QueryDef
Set qdf = CurrentDb.QueryDefs(ComponentQ)
qdf.Parameters("PartNumber") = PartNumber
Set GetComponents = qdf.OpenRecordset
End Function

Related

Deleting record from table is not actually deleting VBA Access

I have a table called Scenarios that has a 1 to many relationship with ESDNodes. There can be multiple ESDNodes that reference a single Scenario.
For every Scenario there must be at least one ESDNode which means that when a scenario is to be deleted, all of its related ESDNodes must then be deleted.
So when the user selects a scenario and attempts to delete it, this function is called:
Private Sub Form_Delete(Cancel As Integer)
Dim scenID As Long
Dim ESDHeadNodeID As Long
Dim response As Long
Dim style As Long
scenID = Forms!Main!Scenarios!ScenarioID
ESDHeadNodeID = DLookup("ESDNodeID", "ESDNodes", "((ESDNodes.ESDNodeType)=1) AND ((ESDNodes.ScenarioID) = " & scenID & ")")
style = vbYesNoCancel + vbQuestion
response = MsgBox("Are you sure you wish to delete all selected nodes and their children?", style)
If response = vbYes Then
DeleteESDChildren (ESDHeadNodeID)
loadESDTreeView
End If
End Sub
In DeleteESDChildren is where I handle deleting all relevant ESDNodes. I removed all code that is irrelevant to the error in this function.
Here is that function:
Public Function DeleteESDChildren(lngID As Long)
Dim rst_Del As Recordset
Set rst_Del = CurrentDb.OpenRecordset("SELECT * FROM ESDNodes WHERE ESDNodeID = " & lngID)
rst_Del.MoveFirst
'Delete the head node
If Not rst_Del.EOF Then
rst_Del.Delete
End If
End Function
I tested this code with the simplest case where there is only one ESDNode for a scenario and the ESDNode has no children. The line that calls rst_Del.Delete, I expect to delete this singular ESDNode. But instead I get an error when the Form_Delete attempts to End Sub claiming "The record cannot be deleted or changed because table 'ESDNodes' includes related records." So this singular ESDNode is not getting deleted.
Screenshot showing the relationships between my tables
This can be achieved using SQL
CurrentDb.Execute "DELETE * FROM ESDNodes WHERE ESDNodeID = " & lngID
Looks like you're in a loop.
Public Function DeleteESDChildren(lngID As Long)
Dim rst As Recordset
'find the children of the node
Set rst = CurrentDb.OpenRecordset("SELECT * FROM ESDNodes WHERE ParentID = " & lngID)
'call deletechildren on each child in turn
While Not rst.EOF
DeleteESDChildren (rst!ESDNodeID) '<-- goes back to the beginning.
rst.MoveNext
Wend
etc.

Access Tab Control - Set Pages Visibilty based on Subform Records

I know how to do this, but wondering if I might be able to write a more elegant solution. I have a form with a tab control. The control has 14 pages, each one, with it's own sub form. One of the pages (pgRequirements) has a subform of requirements, with a combo control "Requirement Type". It is a continuous form, so the user can add as many requirements as they want, for the main record.
There are 9 of those requirements, which have their own tab control page / sub form. I want to set visibility of those tab control pages, based on this parent's sub form requirements. So a current main record, can have multiple sub-requirement records. If any of those match e.g. requirement type A, than page A should be visible, otherwise it should not be.
I need this code to run anytime the main form is loaded, and the detail is made visible (meaning a main record has been chosen from a find form). Also anytime a requirement record is added or removed. The below is assuming that the parent-child links on the main form to subform will limit the requirement records, to just those that are for the current main record.
Here is the simple code, that will do the job, but is probably over-written:
If Me.FKRequirementType.Column(1) = "ReqType1" Then
Me.Parent!pgReqType1.Visible = True
Else
Me.Parent!pgReqType1.Visible = False
End If
If Me.FKRequirementType.Column(1) = "ReqType2" Then
Me.Parent!pgReqType2.Visible = True
Else
Me.Parent!pgReqType2.Visible = False
End If
If Me.FKRequirementType.Column(1) = "ReqType3" Then
Me.Parent!pgReqType3.Visible = True
Else
Me.Parent!pgReqType3.Visible = False
End If
If Me.FKRequirementType.Column(1) = "ReqType4" Then
Me.Parent!pgReqType4.Visible = True
Else
Me.Parent!pgReqType4.Visible = False
End If
Thanks!
EDIT
I turned this into a public function, so I can call it from anywhere. One problem. It's not working lol (small problem). I don't get any errors, but all the tab control pages are visible. When I add a new record, most of them should be hidden. I have a tblReqType table, with all the requirement types. I added a column to this, with the exact name of it's corresponding tab control page name, so I can loop through that table, for all records where that page name is not null, and set their page visible or not, based on the current main record ID having a record-requirement (cross reference table) record for each requirement type.
This is the public function I wrote. Can anyone help me understand what I'm missing in these loops for setting the visibility true (vtrue) vs setting the visibility false (vfalse)
Public Function ShowRequirements()
Dim db As DAO.Database
Dim strRstVTrue As String
Dim rstvTrue As DAO.Recordset
Dim strRstVFalse As String
Dim rstvFalse As DAO.Recordset
Dim strFieldName As String
'Setup the recordset
Set db = CurrentDb
strRstVTrue = "SELECT tblMRecordRequirements.ID, tblMRecordRequirements.FKMC, tblReqType.txtRequirementPage " & _
"FROM tblMRecordRequirements LEFT JOIN tblReqType ON tblMRecordRequirements.FKRequirementType = tblReqType.ID " & _
"WHERE tblReqType.txtRequirementPage Is Not Null AND tblMRecordRequirements.FKMC = " & Nz(Forms!frmMRecords!ID, 0)
strRstVFalse = "SELECT tblReqType.ID, tblReqType.txtRequirementPage, tblMRecordRequirements.FKMC " & _
"FROM tblReqType LEFT JOIN tblMRecordRequirements ON tblReqType.ID = tblMRecordRequirements.FKRequirementType " & _
"WHERE tblReqType.txtRequirementPage Is Not Null AND tblMRecordRequirements.FKMC <> " & Nz(Forms!frmMRecords!ID, 0)
Set rstvTrue = CurrentDb.OpenRecordset(strRstVTrue, dbOpenDynaset, dbSeeChanges)
Set rstvFalse = CurrentDb.OpenRecordset(strRstVFalse, dbOpenDynaset, dbSeeChanges)
strFieldName = "txtRequirementPage"
Do While Not rstvTrue.EOF
Forms!frmMRecords.tbMRecordSubs.Pages(rstvTrue.Fields(strFieldName)).Visible = True
Loop
Do While Not rstvFalse.EOF
Forms!frmMRecords.tbMRecordSubs.Pages(rstvFalse.Fields(strFieldName)).Visible = False
Loop
End Function
If anyone can help me figure out my stupidity, you deserve an up vote, a check mark, and a cookie.
EDIT again
Below is updated code for the public function. I fixed the rs for the true query, and I added in the MoveNext for the loops.
Public Function ShowRequirements()
Dim db As DAO.Database
Dim strRstVTrue As String
Dim rstvTrue As DAO.Recordset
Dim strRstVFalse As String
Dim rstvFalse As DAO.Recordset
Dim strFieldName As String
'Setup the recordset
Set db = CurrentDb
strRstVTrue = "SELECT tblMRecordRequirements.ID, tblMRecordRequirements.FKMC, tblReqType.txtRequirementPage " & _
"FROM tblMRecordRequirements LEFT JOIN tblReqType ON tblMRecordRequirements.FKRequirementType = tblReqType.ID " & _
"WHERE tblReqType.txtRequirementPage Is Not Null AND tblMRecordRequirements.FKMC = " & Nz(Forms!frmMRecords!ID, 0)
strRstVFalse = "SELECT tblReqType.ID, tblReqType.txtRequirementPage, tblMRecordRequirements.FKMC " & _
"FROM tblReqType LEFT JOIN tblMRecordRequirements ON tblReqType.ID = tblMRecordRequirements.FKRequirementType " & _
"WHERE tblReqType.txtRequirementPage Is Not Null AND tblMRecordRequirements.FKMC <> Is Null"
Set rstvTrue = CurrentDb.OpenRecordset(strRstVTrue, dbOpenDynaset, dbSeeChanges)
Set rstvFalse = CurrentDb.OpenRecordset(strRstVFalse, dbOpenDynaset, dbSeeChanges)
strFieldName = "txtRequirementPage"
Do While Not rstvTrue.EOF
Forms!frmMRecords.tbMRecordSubs.Pages(rstvTrue.Fields(strFieldName)).Visible = True
rstvTrue.MoveNext
Loop
Do While Not rstvFalse.EOF
Forms!frmMRecords.tbMRecordSubs.Pages(rstvFalse.Fields(strFieldName)).Visible = False
rstvFalse.MoveNext
Loop
End Function
EDIT REDUX
I think I may have it worked out, but let me know what you all think. I really appreciate all your thoughts on this, as I know you all have a lot of experience not just in figuring out these kinds of challenges, but ensuring the code is good and not prone to issues.
Here is where I am at:
Public Function ShowRequirements()
Dim db As DAO.Database
Dim db2 As DAO.Database
Dim strRstVTrue As String
Dim rstvTrue As DAO.Recordset
Dim strRstVFalse As String
Dim rstvFalse As DAO.Recordset
Dim strFieldName As String
strFieldName = "txtRequirementPage"
Set db = CurrentDb
Set db2 = CurrentDb
strRstVTrue = "SELECT tblReqType.txtRequirementPage " & _
"FROM tblReqType LEFT JOIN tblMRecordRequirements ON tblMRecordRequirements.FKRequirementType = tblReqType.ID " & _
"WHERE tblReqType.txtRequirementPage Is Not Null AND tblMRecordRequirements.FKMC = " & MCID
strRstVFalse = "SELECT tblReqType.txtRequirementPage " & _
"FROM tblReqType LEFT JOIN tblMRecordRequirements ON tblMRecordRequirements.FKRequirementType = tblReqType.ID " & _
"WHERE tblMRecordRequirements.ID Not In (Select ID From [tblMRecordRequirements] WHERE [tblMRecordRequirements]![FKMC] = " & MCID & _
") AND tblReqType.txtRequirementPage Is Not Null;"
Set rstvTrue = db.OpenRecordset(strRstVTrue, dbOpenDynaset, dbSeeChanges)
Set rstvFalse = db2.OpenRecordset(strRstVFalse, dbOpenDynaset, dbSeeChanges)
Do While Not rstvTrue.EOF
Forms!frmMRecords.tbMRecordSubs.Pages(rstvTrue.Fields(strFieldName)).Visible = True
rstvTrue.MoveNext
Loop
Do While Not rstvFalse.EOF
Forms!frmMRecords.tbMRecordSubs.Pages(rstvFalse.Fields(strFieldName)).Visible = False
rstvFalse.MoveNext
Loop
End Function
I need this code to run anytime the main form is loaded, and the detail is made visible (meaning a main record has been chosen from a find form). Also anytime a requirement record is added.
Put the code you shared inside a sub procedure and call the sub procedure from Form_Load(), Form_Current(), Form_AfterInsert() event handler, etc.
As for elegance, I'd focus on maintainability and efficiency rather than looks, but concise code is also nice. 1) You can use a With block to reduce redundant object method calls, but that'll only work for one reference at a time. 2) Instead create another variable to temporarily hold a value/object from a series of dot property-accessors. 3) It looks like pages and column values are already numbered with a consistent naming pattern, so leverage that in a loop. 4) Comparison operations in VBA are largely Boolean operations, so they return True or False. The result of an entire Boolean expression can be assigned to another Boolean variable/property. (Boolean operations can also return Null... which is usually, but not always, treated like False. If you're certain that your data doesn't have Null values, then you can simplify the code and ignore this issue. If the data can contain null, then you need to adjust the code appropriately.)
Me.Parent!pgReqType1 is calling the default property of the Parent form which is Controls, which default property is Item. The bang operator ! passes the code text as a string into the collection Item method. In short, it is equivalent to Me.Parent.Controls.Item("pgReqType1").
Dim i as integer
Dim ctls as Controls
Dim reqValue as string
Set ctls = Me.Parent.Controls
reqValue = Me.FKRequirementType.Column(1)
For i = 1 to 4
ctls.Item("pgReqType" & i).Visible = (reqValue = "ReqType" & i)
Next i
About all I can do is translate the specific code snippet you show. I have the feeling there is probably more to it than this, because the code snippet you shared ensures that there will only be one tab visible: It is testing the same column value multiple times which could only have one value. Bug? Incomplete example?
This really goes against my better judgement of Stack Overflow principles --to not answer multi-part, continuing debugging questions-- but I really want a cookie.
How could the posted code have ever worked, since you are not moving through either recordset? There are no MoveNext calls. That means that both recordsets are empty or an error is being thrown that is being ignored somewhere (i.e. On Error Resume Next). Otherwise, it should lock up Access with infinite loops. Sometimes you can stop the code with Ctrl+Break, but not always successful in Access.
More precise table schema is required to properly interpret your data, but I'll make some assumptions. You state that tblReqType contains all requirement types. I'll assume that tblMRecordRequirements contains rows only for requirements which are "applied" (a.k.a. "on", "selected") for the ID value in tblMRecordRequirements.FKMC. Assuming the converse, if there are no rows in tblMRecordRequirements with ID in tblMRecordRequirements.FKMC for a given tblMRecordRequirements.FKRequirementType, then the requirement is not "applied" to that ID.
Does every row in tblReqType have a value in txtRequirementPage, or do some rows have null values? Also, can multiple requirements have the same page specified? Or is it a true one-to-one requirement-to-page mapping with no null values?
First of all why would the first query not be an INNER JOIN, since I assume that only records that match in both tables should be returned for the Visible = True condition? Depending on your answers above, this would probably make the condition tblReqType.txtRequirementPage Is Not Null unnecessary in the first query.
Simply reversing a LEFT JOIN will not return what you want especially if you select all other ID values ( tblMRecordRequirements.FKMC <> Nz(Forms!frmMRecords!ID, 0) ). All that does is give you the requirements for every other ID values. Not only will that be inefficient since it could return many, many irrelevant records, it could be likely that over all other ID values that every possible requirement would be applied, so that the second query will essentially cause all requirements to be invisible.
Further picky observations:
If Forms!frmMRecords!ID is null, then you might as well not even execute the queries. You should check that value for null separately and perform appropriate actions rather than letting that specific condition fall through the other code, even if the end side effect is what you desire. It makes the code harder to debug and interpret properly. In other words write code that does "If ID is null, set all pages to visible = false, then exit the sub (i.e. skip other code)"
It's more efficient to get a read-only snapshot rather than an fully-updatable Dynaset recordset: Too much overhead just for looping through without data manipulation.
Proper break points, debug output and error handling code can help identify bad code. It is worth tracing through results of recordsets manually to inspect values and proper SQL syntax.
Try this:
Public Sub ShowRequirements()
Dim db As DAO.Database
Dim iID As Long '? Assuming long integer
Dim strSQL As String
Dim rsTabs As DAO.Recordset
On Error Resume Next
iID = -1 '* Set to bogus value
If Not IsNull(Forms!frmMRecords!ID) Then
iID = Forms!frmMRecords!ID
End If
If iID = -1 Or Err.Number <> 0 Then
'* Problem accessing ID control on form (empty recordset, new record row, etc.)
'* or it is null
'Set all tab pages to Visible = False?
Exit Sub
End If
On Error GoTo Catch
'* Setup the recordset
Set db = CurrentDb
'* Use embedded query (replacable with saved query) for filtering on ID values.
'* This is critical so that the LEFT JOIN does not return or filter records
'* based on other ID values.
strSQL = _
"SELECT tblReqType.ID, tblReqType.txtRequirementPage, (IDReq.FKRequirementType Is Not Null) As ShowTab " & _
" FROM tblReqType LEFT JOIN" & _
" (SELECT MReq.FKRequirementType FROM tblMRecordRequirements AS MReq " & _
" WHERE MReq.FKMC = " & iID & ") AS IDReq" & _
" ON tblReqType.ID = IDReq.FKRequirementType" & _
" WHERE tblReqType.txtRequirementPage Is Not Null"
Set rsTabs = db.OpenRecordset(strRstVTrue, dbOpenSnapshot, dbReadOnly)
Do While Not rsTabs.EOF
Forms!frmMRecords.tbMRecordSubs.Pages(rsTabs!txtRequirementPage).Visible = rsTabs!ShowTab
rsTabs.MoveNext '* Advance recordset. (Avoid infinite loops.)
Loop
CloseAll:
On Error Resume Next
'* Best habit to explicitly close recordsets and database connections, even when not necessary (since they'll close automatically when they go out of scope)
If Not rsTabs Is Nothing Then
rsTabs.Close
Set rsTabs = Nothing
End If
Set db = Nothing
Exit Sub
Catch:
'* At least report error for development
Debug.Print "ShowRequirements(): Error: " & Err.Number & ": " & Err.Description
'* Show MsgBox or update form status control?
'* Set all tab pages to Visible = False?
'* Form state could be misleading without proper user notification and/or error handling
Resume CloseAll
End Sub

Transpose a table in Access using VB code

I have a table that is populated with data from a delimited text file. The data comes from another system and I cannot modify how it is generated into the text file I am importing. Once the data is imported into access, it is not in a normalized fashion. The first two columns of data are date ranges, the third is a location code, the remaining 54 columns hold specific data for each location. I need to find the top five values for each record so I can put them into a report.
I had posed this question in another thread, but was unable to find a solution. In that thread, someone recommended that I used a union query. It appeared that it was going to work perfectly, but you can only use 50 unions in access and I have to many fields.
Now I am trying to use VB code in access to transpose the table. I am working with the following code that I retrieved from this page. It is throwing an error on execution. I cannot figure out what the issue is. I know it is a syntax error or creating the object, but I have tried everything I can think of and cannot get it to work. Also, The column headers would contain string info so I was going to change the variable to a variant instead of an integer? Any help with this code, or suggestions regarding how to get what I want from the table would be appreciated.
Picture of actual table.
I am getting a error -> 'Run-time error '3265': Item not found in this collection.
Private Sub Command78_Click()
Const cstrInputTable = "Base Period OT"
Const cstrOutputTable As String = "Normalized Base Period OT"
Dim dbs As DAO.Database
Dim rstInput As DAO.Recordset
Dim rstOutput As DAO.Recordset
Dim intYear As Integer
Set dbs = CurrentDb
Set rstInput = dbs.OpenRecordset(cstrInputTable)
Set rstOutput = dbs.OpenRecordset(cstrOutputTable)
If Not rstInput.EOF Then
' For each column in the Input table, create a record in the output table
For intYear = 1990 To 2011
rstInput.MoveFirst
rstOutput.AddNew
rstOutput![Year] = intYear
' Go through every record in the Input table
Do
rstOutput(rstInput![Data Type]) = rstInput(CStr(intYear))
rstInput.MoveNext
Loop Until rstInput.EOF
rstOutput.Update
Next intYear
End If
rstInput.Close
rstOutput.Close
dbs.Close
MsgBox "Data Successfully Transformed"
DoCmd.OpenTable cstrOutputTable
End Sub
Still not sure I have fully understood your inputs and outputs. I'll give it a try though and you let me know if I'm even close to what you're looking for.
You can create a "Temp" table with only 3 fields just for sorting purposes. You can then loop through your source table and add Location, Column header (3 letter code) and the value of each field to the "Temp" table.
You can then sort by value DESC and select the top 5.
Public Sub GetTopFive()
On Error GoTo ErrProc
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("SELECT Location, AMR, AXT, BRM, BMM, CSR, CTC " & _
"FROM DataSource ORDER BY Location;", dbOpenSnapshot)
If rs.EOF Then GoTo Leave
With rs
.MoveLast
.MoveFirst
End With
Dim idx As Long
For idx = 1 To rs.RecordCount
AddToTempTable rs
'Now the Temp table holds one Location, sorted by value
'Selecting the top 5 records will give you what you're looking for
'If that's the case, provide additional info on how to handle this
'as each location might have different field names.
rs.MoveNext
Next idx
Leave:
On Error Resume Next
rs.Close
Set rs = Nothing
On Error GoTo 0
Exit Sub
ErrProc:
MsgBox Err.Description, vbCritical
Resume Leave
End Sub
'Add To Temp for sorting
Private Sub AddToTempTable(rs As DAO.Recordset)
Dim fld As DAO.Field
For Each fld In rs.Fields
If fld.Name <> "Location" Then
With CurrentDb.QueryDefs("qryAddToTemp")
.Parameters("[prmLocation]").Value = rs!Location
.Parameters("[prmFileldName]").Value = fld.Name
.Parameters("[prmFieldValue]").Value = fld.Value
.Execute dbFailOnError
End With
End If
Next fld
End Sub
Import query
PARAMETERS [prmLocation] Text ( 255 ), [prmFileldName] Text ( 255 ), [prmFieldValue] IEEESingle;
INSERT INTO tbTemp ( Location, [Field Name], [Field Value] )
SELECT [prmLocation] AS Location, [prmFileldName] AS [Field Name], [prmFieldValue] AS [Field Value];
Temp Table
Update:
Public Sub GetTopFive()
On Error GoTo ErrProc
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("SELECT Location, AMR, AXT, BRM, BMM, CSR, CTC " & _
"FROM DataSource ORDER BY Location;", dbOpenSnapshot)
If rs.EOF Then GoTo Leave
With rs
.MoveLast
.MoveFirst
End With
Dim rsTemp As DAO.Recordset, fld As DAO.Field, idx As Long
Set rsTemp = CurrentDb.OpenRecordset("tbTemp")
With rsTemp
For idx = 1 To rs.RecordCount
For Each fld In rs.Fields
If fld.Name <> "Location" Then
.AddNew
.Fields("YourCodeColumnName").Value = fld.Name
.Fields(rs!Location).Value = fld.Value
.Update
End If
Next fld
rs.MoveNext
Next idx
End With
Leave:
On Error Resume Next
rsTemp.Close
Set rsTemp = Nothing
rs.Close
Set rs = Nothing
On Error GoTo 0
Exit Sub
ErrProc:
MsgBox Err.Description, vbCritical
Resume Leave
End Sub
Based on what you have provided there are 6 possibilities of where you are getting error 3265, and 4 of them have the same solution, once you understand how DAO Recordset objects work and reference fields in the "Table" they represent.
The error Item not found in this collection, given the code you have presented indicates that you are referencing a field name (column name) in the recordset that does not exist. Or, that you are referencing a table name that does not exist in the database.
Since your code is dynamically determining field names, and you haven't provided the structure of the tables Base Period OT or Normalized Base Period OT, you will have to figure part of this out on your own.
Here are the 4 places where the error could be occurring for the Recordset objects and what you are looking for:
rstOutput![Year] = intYear, you are telling Access that you expect a column named "Year" to exist in your table Normalized Base Period OT and that you want to insert the current value of intYear into that column. If "Year" is not a column name in that table, this would be the problem.
3, & 4. rstOutput(rstInput![Data Type]) = rstInput(CStr(intYear)) In this single line of code, you have 3 possible locations for the error.
a. rstInput![Data Type] Does the table Base Period OT contain a column named "Data Type"? If not, this would be an error. Here you are statically providing the name of the column that you expect to exist in the input table.
b. rstOutput(rstInput![Data Type]) Assuming that rstInput![Data Type] is a valid column, the value in that column is now the name of the column you are expecting to exist in Normalized Base Period OT. If that is not true, this would be an error. Here, you are dynamically providing the name of the column that you expect to exist in the output table.
c. rstInput(CStr(intYear)) Does the table Base Period OT contain a column for the current value of intYear (i.e. does that table contain columns named 1990, 1991, 1992, etc through 2011 as defined in your loop?) If not, this would be an error. Here, again, you are dynamically providing the name of the column that you expect to exist in the input table.
5 & 6. You could also receive this error on your OpenRecordset commands if the tables, named in your two constants don't exist.
This addresses the issue with your code sample, but does not address whether your approach to transform the data for your other stated purposes is correct or not as we do not have enough additional information.

How would I make a form which searches for values in all tables of a database in access

I am trying to make a form which searches for the value inside all of the tables in the database (there are more than 1 table). The result will be displayed as the name of the table which this appears in. If someone can help me that will be nice.
In short, I have a form with a textbox and button. I enter the search string (for example 183939) and click on the button. It searches the value (183939) inside all the fields in the tables in the database, and if the value is found, then it displays the name of the table that it appears in. Thanks for the help.
I think this is a bad idea because it could take a very long time, and provide confusing results due to also searching system tables... but the following function will return an array of all table names containing the search term or nothing if it wasn't found. Calling example is such: theTables = containingTable("hello") where theTables is a variant. A limitation is that this will fail for multi-valued fields.
Function containingTables(term As String)
Dim db As Database
Dim tds As TableDefs
Dim td As TableDef
Set db = CurrentDb
Set tds = db.TableDefs
For Each td In tds
For Each f In td.Fields
On Error Resume Next
If DCount("[" & f.Name & "]", "[" & td.Name & "]", "[" & f.Name & "] LIKE '*" & term & "*'") Then
If Err.Number <> 0 Then
Debug.Print Err.Number, Err.Description
Err.Clear
On Error GoTo 0
Else
containingTables = containingTables & td.Name & ","
Exit For
End If
End If
Next
Next
Set tds = Nothing
Set db = Nothing
'Alternate Version
if Len(containgingTables) then containingTables = Left(containingTables, Len(containingTables) - 1)
'Original Version
'if Len(containgingTables) then containingTables = Split(Left(containingTables, Len(containingTables) - 1), ",")
End Function
To display the results with the alternate version, just use: Msgbox(containingTables(searchTerm)) where searchTerm is whatever you are searching.
Me as well i don't know why you would want to do something like that...
I think the solution posted by Daniel Cook is correct, i just took a slightly different approach. Do you need to match the exact value like I do? Anyway, here's my code:
Function searchTables(term as String)
Dim T As TableDef
Dim Rs As Recordset
Dim Result() As String
Dim Counter
Counter = 0
For Each T In CurrentDb.TableDefs
If (Left(T.Name, 4) <> "USys") And (T.Attributes = 0) Then
Set Rs = T.OpenRecordset
While Not Rs.EOF
For Each Field In Rs.Fields
If Rs(Field.Name) = term Then
Counter = Counter + 1
ReDim Preserve Result(Counter)
Result(Counter) = T.Name & "," & Field.Name
End If
Next
Rs.MoveNext
Wend
Rs.Close
End If
Next
If Counter = 0 Then
searchTables = Null
Else
searchTables = Result
End If
End Function
You should filter out duplicated values, in case the function matches multiple times the same filed in the same table.

Are there issues with tables using an autonumber as a primary key in a back-end ms access db?

I inherited an MS Access database at my office that is heavily used by several people over the network. This causes many issues with data collisions and locks. I want to split the db so that each user has thier own front-end app and maintain the core data on the server.
Several of the tables use an autonumber:sequence:long as thier primary key - in researching how to perform the split I've come across several posts that hint this can cause issues when distributing a database but I haven't been able to find anything solid. The issue seems to be that a user can begin a new record and receive the next autonumber but a second user can create a new record within a short interval and receive the same autonumber resulting in an error?
Does Jet handle this correctly or are there autonumber issues with a FE/BE database? If it's an unlikely-but-possile occurance I'm sure it will still be much better than what my users are currently experiencing but I'd like to know if there are ways I can minimize such issues.
Thanks for your help!
I've had the misfortune of working with many Access databases in my youth. While there are many issues with Access, I do not know if I've ever run into a problem with AutoNumber columns in a split database, multi-user environment. It should work fine. This is such a common setup that there would be posts all over the Internet about it if were an issue.
As long as you are not going for data replication (ie multiple subscriber databases, where users can insert new records in same tables but in different locations), you will not have problems with autonumbers as primary keys.
If you think that one of these days you might need to go for replication (different locations, one central database), do not hesitate to switch to unique identifiers (replication IDs).
There seems to be some confusion on your part about the process of splitting. When you do so, you end up with multiple front ends, but the back end is still a single file. Thus, there's no difference at all for the data tables in terms of Autonumbers from what you had before you split the application.
I had the same problem, nevertheless i did a workarround to get the autonumbering work from an Onload() Event
What I did is :
I create a recordset based on Your_Table everytime the user needs an autonumber
Open the recordset (rst)
Search if:
-Your_Table is Empty, then assigns the value "1" to Your_field
-Your_Table is has data without missing numbers,then assigns the value = "Count of lines + 1" to Your_field (1,2,....,n+1)
-Your_Table has missing data (1,3,4,5,7) [Note "#2 and #7 are missing]", then uses a function to search in Your_Table the missing fields and assign to Your_Field the first missing value (#2 in this example)
Private Sub Autonumbering(Your_Table As String)
Dim rst As DAO.Recordset
Dim db As Database
On Error GoTo ErrorHandler
Application.Echo False
Set db = CurrentDb
Set rst = db.OpenRecordset(Your_Table, dbOpenDynaset)
With rst
.AddNew
'Your_Table is Empty, **then** assigns the value "1" to Your_field
If DMin("[Your_Field]", Your_Table) = 1 Then
'Your_Table is has data without missing numbers,**then** assigns the value = "Count of lines + 1" to Your_field (1,2,....,n+1)
If DMax("[Your_Field]", Your_Table) = .RecordCount Then
'Assings n+1 value to [Your_Field] records
Value = .RecordCount + 1
![Your_Field] = Valor
Else
'Your_Table has missing data (1,3,4,5,7) [Note "#2 and #7 are missing]", **then** uses a function to search in Your_Table & _
the missing fields and assign to Your_Field the first missing value (#2 in this example)
Value = MyFunction$(Your_Table, "Your_Field")
![Your_Field] = Value
End If
Else
'Agrega el número 1
Value = 1
![Your_Field] = Value
End If
.Update
.Bookmark = .LastModified
Me.Requery
DoCmd.GoToRecord acDataForm, Me.Name, acGoTo, Value
.Move 0, .LastModified
End With
ErrorCorregido:
Application.Echo True
Exit Sub
ErrorHandler:
MsgBox "An error ocurred, please verify numbering", vbCritical + vbOKOnly
Resume ErrorCorregido
End Sub
Here is the function that i found to get the missing values on an specific table, i cant find it anymore, but thanks for the one who made it.
Function MyFunction$(cstrTable As String, cstrField As String)
' Read table/query sequentially to record all missing IDs.
' Fill a ListBox to display to found IDs.
' A reference to Microsoft DAO must be present.
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim lst As ListBox
Dim Col As Collection
Dim strSQL As String
Dim strList As String
Dim lngLast As Long
Dim lngNext As Long
Dim lngMiss As Long
' Build SQL string which sorts the ID field.
strSQL = "Select " & cstrField & "" _
& " From " & cstrTable & " Order By 1;"
Set Col = Nothing
' Control to fill with missing numbers.
'Set lst = Me!lstMissing
' Collection to hold the missing IDs.
Set Col = New Collection
'// Vacía la colección
'Erase Col
' Read the table.
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(strSQL)
If rst.RecordCount = 0 Then
' The recordset is empty.
' Nothing to do.
Else
' Read and save the ID of the first record.
lngLast = rst(cstrField).value
rst.MoveNext
' Loop from the second record through the recordset
' while reading each ID.
While rst.EOF = False
lngNext = rst(cstrField).value
' For each ID, fill the collection with the
' missing IDs between the last ID and this ID.
For lngMiss = lngLast + 1 To lngNext - 1
Col.Add (lngMiss)
Next
' Save the last read ID and move on.
lngLast = lngNext
rst.MoveNext
Wend
' Finally, add the next possible ID to use.
Col.Add (lngLast + 1)
End If
rst.Close
For lngMiss = 1 To Col.Count
' Build the value list for the ListBox.
If Len(strList) > 0 Then
' Append separator.
strList = strList & ";"
End If
' Append next item from the collection.
strList = strList & Col(lngMiss)
' For debugging only. May be removed.
Debug.Print Col(lngMiss)
Next
' Pass the value list to the ListBox.
' Doing so will requery it too.
' lst.RowSource = strList
' For debugging only. May be removed.
' Debug.Print strList
MyFunction$ = Col(1)
' Clean up.
Set rst = Nothing
Set dbs = Nothing
Set Col = Nothing
Set lst = Nothing
End Function