I was asked to write some code to provide a counter that would count by company and reset for a new company. As they want to be able to query off that and export the results for example Company A may have 10 rows (1 - 10), company B 3 rows (1 - 3), Company C 18 rows (1 - 18), Company D 1 row. They would then decide "I'd like a max of 5 rows per company", they would then get 5 rows from Company A, 3 rows from B, 5 from C and 1 from D. I looked at various queries to do this, but due to size of source tables, decided to add a numeric col to the table and populate via recordset incrementing by 1 until a new company name appears, then resetting 1 to and increment again. I have two summary queries and a form with subforms that show how many rows companies have and then by company how many rows.
For example, 1st query shows 38 2, this means there are 2 companies that have 38 rows. The 2nd query provides the names of the companies.
User then selects from the drop down and that then saves the results to a table or exports to excel.
At home I have Access 2013 and the code works fine (so far), but at the office, they have 2010 and after about 20,000 rows it says system resources exceeded. The table becomes corrupt because when I try to open it manually it says system resources exceeded and becomes #name.
I've looked at various threads and tried some of the solutions, so far I haven't gotten them to work in my case. Could the problem be because I'm altering the table in the back end? Perhaps someone may have another idea.
For example, 1st query shows 38 2, this means there are 2 companies that have 38 rows. The 2nd query provides the names of the companies.
User then selects from the drop down and that then saves the results to a table or exports to excel.
At home I have Access 2013 and the code works fine (so far), but at the office, they have 2010 and after about 20,000 rows it says system resources exceeded. The table becomes corrupt because when I try to open it manually it says system resources exceeded and becomes #name.
I've looked at various threads and tried some of the solutions, so far I haven't gotten them to work in my case. Could the problem be because I'm altering the table in the back end? Perhaps someone may have another idea.
Code:
Public Sub CompanyCount()
'Create a column to count up number of rows
'in a company and then reset counter for
'next company to be used by query to filter
'specified number of rows for each company
'such as "Select 10 rows from each company"
'http://www.granite.ab.ca/access/backendupdate.htm
'20150522
Dim db As DAO.Database
Dim qd As DAO.QueryDef
Dim td As DAO.TableDef
Dim fld As DAO.Field
Dim rs As DAO.Recordset
Dim stsql As String
Dim stCompany As String
Dim stFindCompany As String
Dim intCounter As Long
Dim stTableName As String
Dim Position As Long
Dim myvalue As Long
Me.btnProcess.Caption = "Generating Counts"
Me.btnProcess.ForeColor = vbRed
On Error GoTo msgerr
Set db = CurrentDb
'This line allows processing more than 9000 records without
'getting the dreaded "Run-Time error '3052' ;
'File sharing lock count exceeded. Increase you MAXLocksPerFile Registry Entry"
'http://www.access-programmers.co.uk/forums/showthread.php?t=185985
'20150529
DAO.DBEngine.SetOption dbMaxLocksPerFile, 500000
myvalue = 0
If IsNull(Me.cboPreview) Then
MsgBox "Choose an input table before proceeding.", vbOKOnly, "Missing Input Table"
Exit Sub
End If
If fieldexists(Me.cboPreview, "COUNTER") Then
stsql = "UPDATE " & Me.cboPreview & " SET COUNTER = '' " & _
"WHERE COUNTER Is Not Null"
CurrentDb.Execute stsql
Else
Set db = DBEngine(0).OpenDatabase(Me.txtProject, True)
Set td = db.TableDefs(Me.cboPreview)
Set fld = td.CreateField("COUNTER", dbLong)
td.Fields.Append fld
Set fld = Nothing
Set td = Nothing
db.Close
Set db = Nothing
Set db = CurrentDb
End If
stsql = "SELECT * FROM " & Me.cboPreview & " ORDER BY COMPANY"
Set rs = db.OpenRecordset(stsql)
With rs
.MoveLast
.MoveFirst
stCompany = rs!Company
intCounter = 0
Do While Not rs.EOF
If stCompany = rs!Company Then
intCounter = intCounter + 1
Else
intCounter = 1
End If
stCompany = rs!Company
Position = .AbsolutePosition
.Edit
rs!COUNTER = intCounter
.Update
.MoveNext
Loop
End With
If QueryExists("qryCoCoByCompany") Then
Set qd = db.QueryDefs("qryCoCoByCompany")
Else
Set qd = db.CreateQueryDef("qryCoCoByCompany")
End If
stsql = "SELECT COMPANY, Max(" & Me.cboPreview & ".COUNTER) AS COUNTER " & _
"FROM " & Me.cboPreview & " " & _
"GROUP BY COMPANY " & _
"ORDER BY max(COUNTER) DESC, COMPANY;"
qd.SQL = stsql
If QueryExists("qryCoCoSums") Then
Set qd = db.QueryDefs("qryCoCoSums")
Else
Set qd = db.CreateQueryDef("qryCoCoSums")
End If
stsql = "SELECT CSUMS.COUNTER, Count(CSUMS.COUNTER) AS No_Of_Companies " & _
"FROM " & Me.cboPreview & " AS CSUMS " & _
"INNER JOIN qryCoCoByCompany AS CNAMES " & _
"ON CSUMS.COMPANY = CNAMES.COMPANY " & _
"AND CSUMS.COUNTER = CNAMES.COUNTER " & _
"GROUP BY CSUMS.COUNTER " & _
"ORDER BY CSUMS.COUNTER DESC;"
qd.SQL = stsql
rs.Close
Set rs = Nothing
Set qd = Nothing
Set db = Nothing
Me.btnProcess.Caption = "Company Count (max count)"
Me.btnProcess.ForeColor = vbBlack
DoCmd.OpenForm "frmCompanyCount"
Exit Sub
msgerr:
MsgBox Err.Number & " " & Err.Description
End Sub
Last edited: