''********************************************************
'' FUNCTION: TransposeTable()
''
'' PURPOSE: Transposes table (turns 90 degrees).
''
'' Written By: Dmonney
''
'' ARGUMENTS:
'' chosen_col: the name of the column you wish to be header.
'' old_table_name: The name of a table or query you wish to transpose.
'' new_table_name: The name of the table you wish the data to be stored in
'' (this table will be automatically deleted if it exists)
''
'' RETURNS: True (successful), false (not successful).
''
'' NOTES: If all fields (exept chosen_col) have the same field type that field type will be used
'' otherwise text fields will be created.
''********************************************************
Public Function TransposeTable(chosen_col As String, old_table_name As String, new_table_name As String) As Boolean
Dim curDatabase As Object
Dim ntable As Object
Dim colFullName As Object
Dim ofieldname As DAO.Field
Dim otable As DAO.Recordset
Dim CD As DAO.Database
Dim OfldCnt As Integer
Dim newfield_name As String
Dim sqlrs As Recordset
Dim DataEntry As String
Dim strsql As String
Dim CurDataEntry As String
Dim NullValue As String
Dim found As Boolean
Dim typecompare As Integer
Dim allsame As Boolean
Dim dataype As String
found = False
Set curDatabase = CurrentDb
' error checking
If (IsTableQuery("", old_table_name) = False) Then
MsgBox ("No Table/query by that name")
TransposeTable = False
End If
Set otable = CurrentDb.OpenRecordset(old_table_name, dbOpenSnapshot)
OfldCnt = 1
For Each ofieldname In otable.Fields
newfieldname = otable.Fields(OfldCnt - 1).Name
OfldCnt = OfldCnt + 1
If newfieldname = chosen_col Then found = True
Next ofieldname
If (found = False) Then
MsgBox ("No such field name in table/query " & old_table_name)
TransposeTable = False
End If
If (old_table_name = new_table_name) Then
MsgBox ("Cannot have old table and new table be the same")
TransposeTable = False
End If
DataEntry = ""
Dim countfields As Integer
OfldCnt = 1
' check to see if table exists and delete it.
If IsTableQuery("", new_table_name) Then curDatabase.TableDefs.Delete new_table_name
' if all the fields exept the chosen field are of the same type then new table will be of that type
OfldCnt = 1
countfields = 0
allsame = True
For Each ofieldname In otable.Fields
newfieldname = otable.Fields(OfldCnt - 1).Name
OfldCnt = OfldCnt + 1
If (newfieldname <> chosen_col) Then 'if i'm not on the chosen collumn
If (typecompare = 0) Then typecompare = ofieldname.Type ' if i'm on the first one set to comparasin
If typecompare <> ofieldname.Type Then
allsame = False
DataType = "DB_TEXT"
Else
DataType = CLng(CLng(ofieldname.Type))
End If
End If
Next ofieldname
' create table
Set ntable = curDatabase.CreateTableDef(new_table_name)
' Add the "Data" column to the Students table
Set colFullName = ntable.CreateField("Data", DB_TEXT)
ntable.Fields.Append colFullName
'loop through old table's chosen collom and create collum names in new table
strsql = "SELECT " & old_table_name & "." & chosen_col & " AS Data FROM TRANSPOSE"
Set sqlrs = CurrentDb.OpenRecordset(strsql)
If Not sqlrs.EOF Then sqlrs.MoveFirst
Do While Not sqlrs.EOF
newfield_name = sqlrs!Data
Set colFullName = ntable.CreateField(newfield_name, DataType)
ntable.Fields.Append colFullName
sqlrs.MoveNext
Loop
CurrentDb.TableDefs.Append ntable
'Set ntable = curDatabase.OpenRecordset(new_table_name, dbOpenDynaset)
DoCmd.SetWarnings False
'Take field names from chosen table and put them into new_table's data collumn
OfldCnt = 1
countfields = 0
For Each ofieldname In otable.Fields
newfieldname = otable.Fields(OfldCnt - 1).Name
OfldCnt = OfldCnt + 1
If (newfieldname <> chosen_col) Then
'loop through old table creating a string that will input data into new table
strsql = "SELECT " & old_table_name & "." & newfieldname & " AS Data FROM TRANSPOSE"
Set sqlrs = CurrentDb.OpenRecordset(strsql)
Select Case CLng(ofieldname.Type) 'ofieldname.Type is Integer, but constants are Long.
Case dbBoolean: NullValue = "No" ' 1
Case dbByte: NullValue = "0" ' 2
Case dbInteger: NullValue = "0" ' 3
Case dbLong: NullValue = "0" ' 4
Case dbCurrency: NullValue = "0.0" ' 5
Case dbSingle: NullValue = "0" ' 6
Case dbDouble: NullValue = "0" ' 7
Case dbDate: NullValue = "0" ' 8
Case dbBinary: NullValue = "0" ' 9 (no interface)
Case dbText: NullValue = " " '10
Case dbLongBinary: NullValue = "0" '11
Case dbMemo: NullValue = " " '12
Case dbGUID: NullValue = " " '15
Case dbBigInt: NullValue = "0" '16
Case dbVarBinary: NullValue = "0" '17
Case dbChar: NullValue = " " '18
Case dbNumeric: NullValue = "0" '19
Case dbDecimal: NullValue = "0" '20
Case dbFloat: NullValue = "0" '21
Case dbTime: NullValue = "0" '22
Case dbTimeStamp: NullValue = "0" '23
End Select
DataEntry = ""
If Not sqlrs.EOF Then sqlrs.MoveFirst
ountfields = 0
Do While Not sqlrs.EOF
If IsNull(sqlrs!Data) Then ' checks for null values and puts a space instead
CurDataEntry = NullValue
Else
CurDataEntry = sqlrs!Data
End If
DataEntry = DataEntry & ", " & Chr(34) & CurDataEntry & Chr(34) ' chr(34) = ' " '
countfields = countfields + 1
' MsgBox (DataEntry)
sqlrs.MoveNext
Loop
DoCmd.RunSQL "INSERT INTO " & new_table_name & " VALUES(" & Chr(34) & newfieldname & Chr(34) & DataEntry & ");"
End If
Next ofieldname
TransposeTable = True
End Function
''********************************************************
'' FUNCTION: IsTableQuery()
''
'' PURPOSE: Determine if a table or query exists.
''
'' ARGUMENTS:
'' DbName: The name of the database. If the database name
'' is "" the current database is used.
'' TName: The name of a table or query.
''
'' RETURNS: True (it exists) or False (it does not exist).
''
''********************************************************
'
Function IsTableQuery(DbName As String, tName As String) As Integer
Dim Db As Database, found As Integer, Test As String
Const NAME_NOT_IN_COLLECTION = 3265
' Assume the table or query does not exist.
found = False
' Trap for any errors.
On Error Resume Next
' If the database name is empty...
If Trim$(DbName) = "" Then
'...then set Db to the current Db.
Set Db = CurrentDb()
Else
'Otherwise, set Db to the specified open database.
Set Db = DBEngine.Workspaces(0).OpenDatabase(DbName)
'See if an error occurred.
If Err Then
MsgBox "Could not find database to open: " & DbName
IsTableQuery = False
Exit Function
End If
End If
' See if the name is in the Tables collection.
Test = Db.TableDefs(tName).Name
If Err <> NAME_NOT_IN_COLLECTION Then found = True
' Reset the error variable.
Err = 0
' See if the name is in the Queries collection.
Test = Db.QueryDefs(tName$).Name
If Err <> NAME_NOT_IN_COLLECTION Then found = True
Db.Close
IsTableQuery = found
End Function
