Function TestThis(TableName As String, GroupField As String, CountField As String)
'Call this from a macro or ?
BuildTheTable TableName, GroupField, CountField
TestThis = True
End Function
Sub BuildTheTable(TableName As String, GroupField As String, CountField As String)
'Called for example: BuildTheTable "Table1", "FullName", "Number"
' Assumes Table1 has fields FullName & Number
Dim tmpTbl As TableDef
Dim db As Database
Dim rst As Recordset
Dim rst2 As Recordset
Dim rstNewTable As Recordset
Dim strTableName As String
Dim strQuery As String
Dim tmpMaxNumbersForAName As Long
Dim i As Long
Dim tmpErr As Long
Dim tmpError As String
Set db = CodeDb()
' Get the max count of values for a Groupfield
tmpMaxNumbersForAName = MaxNumbersForAName(TableName, GroupField, CountField)
strTableName = "zTbl" & TableName
On Error Resume Next
db.TableDefs.Delete strTableName
tmpErr = Err.Number
tmpError = Err.Description
Err.Clear
Select Case tmpErr
Case 0 ' no error so table deleted OK
Case 3265 ' table doesn't exist, we were going to whack it anyway, so keep going.
Case Else
GoTo Err_BuildTheTable
End Select
On Error GoTo Err_BuildTheTable
Set tmpTbl = db.CreateTableDef(strTableName)
With tmpTbl
.Fields.Append .CreateField(GroupField, dbText)
For i = 1 To tmpMaxNumbersForAName
.Fields.Append .CreateField(CountField & Format(i, "000"), dbLong)
Next i
End With
db.TableDefs.Append tmpTbl
Set tmpTbl = Nothing
Set rstNewTable = db.OpenRecordset("Select * from " & strTableName)
Set rst = db.OpenRecordset("SELECT DISTINCT " & GroupField & " FROM " & TableName)
While Not rst.EOF
Set rst2 = db.OpenRecordset("SELECT " & CountField & " FROM " & TableName & _
" where " & GroupField & " ='" & _
rst.Fields(0).Value & "' Order by " & CountField)
With rstNewTable
.AddNew
.Fields(0).Value = rst.Fields(0).Value
i = 1
While Not rst2.EOF
.Fields(i).Value = rst2.Fields(0).Value
rst2.MoveNext
i = i + 1
Wend
.Update
End With
Set rst2 = Nothing
rst.MoveNext
Wend
Exit_BuildTheTable:
Exit Sub
Err_BuildTheTable:
If Err > 0 Then
MsgBox Err & " - " & Error
Else
MsgBox tmpErr & " - " & tmpError
End If
Resume Exit_BuildTheTable
End Sub
Function MaxNumbersForAName(TableName As String, GroupField As String, CountField As String)
On Error GoTo Err_MaxNumbersForAName
Dim tmpqry As QueryDef
Dim db As Database
Dim rst As Recordset
Dim strQueryName As String
Dim strQuery As String
Set db = CodeDb()
strQueryName = "zQry1" & TableName
strQuery = "SELECT " & GroupField & ", Count("
strQuery = strQuery & CountField & ") AS CountOf" & CountField
strQuery = strQuery & " FROM " & TableName
strQuery = strQuery & " GROUP BY " & GroupField
On Error Resume Next
Set tmpqry = db.CreateQueryDef(strQueryName, strQuery)
Select Case Err.Number
Case 0
Case 3012 ' The query already existed but this will overwrite.
Set tmpqry = db.QueryDefs(strQueryName)
tmpqry.SQL = strQuery
Case Else
GoTo Err_MaxNumbersForAName
End Select
On Error GoTo Err_MaxNumbersForAName
' to pop the tmp query at this point
' DoCmd.OpenQuery strQueryName, acViewNormal, acEdit
'Now build a second query to find the highest count of numbers - should return just 1 record.
strQuery = "SELECT Max(CountOf" & CountField & " ) AS MaxOfCountOf" & CountField
strQuery = strQuery & " FROM " & strQueryName
strQueryName = "zQry2" & TableName
On Error Resume Next
Set tmpqry = db.CreateQueryDef(strQueryName, strQuery)
Select Case Err.Number
Case 0
Case 3012 ' The query already existed but this will overwrite.
Set tmpqry = db.QueryDefs(strQueryName)
tmpqry.SQL = strQuery
Case Else
GoTo Err_MaxNumbersForAName
End Select
On Error GoTo Err_MaxNumbersForAName
Set rst = db.OpenRecordset(strQueryName)
If Not rst.EOF Then
MaxNumbersForAName = rst.Fields(0).Value
Else
MaxNumbersForAName = -1
End If
' to pop the tmp query at this point
' DoCmd.OpenQuery strQueryName, acViewNormal, acEdit
Set rst = Nothing
Set tmpqry = Nothing
Set db = Nothing
Exit_MaxNumbersForAName:
Exit Function
Err_MaxNumbersForAName:
MsgBox Err.Number & " - " & Err.Description
MaxNumbersForAName = -2
Resume Exit_MaxNumbersForAName
End Function
