I just tested and following worked for your sample data....
Copy following code into new module.
Save module as (say) "modTranspose"
In top menu, click on Debug/Compile to make
sure no problems with wordwrap, etc.
'***start new code****
Option Explicit
Public Function TableExists(strTableName As String) As Boolean
'from Joe Fallon
On Error Resume Next
TableExists = IsObject(CurrentDb.TableDefs(strTableName))
End Function
'following function adapted from code by Amy Vargas:
'2. To test the function, open the Debug window (or the Immediate window
' in Microsoft Access version 2.0). If you are in the sample database
' Northwind.mdb (or Nwind.mdb), for example, and you want to transpose
' the Suppliers table, type the following line, and then press ENTER:
'
' "?Transposer("Suppliers","SuppliersTrans")"
'
'(without the quotation marks)
'
'Regards,
'
'Amy Vargo
'Microsoft Access Engineer
Function Transposer(strSource As String, strTarget As String) As Boolean
Dim db As DAO.Database
Dim tdfNewDef As DAO.TableDef
Dim fldNewField As DAO.Field
Dim rstSource As DAO.Recordset
Dim rstTarget As DAO.Recordset
Dim i As Long, j As Long
On Error GoTo Transposer_Err
Set db = CurrentDb()
Set rstSource = db.OpenRecordset(strSource)
rstSource.MoveLast
'delete target table if it exists
If TableExists(strTarget) = True Then
db.Execute "DROP TABLE " & strTarget, dbFailOnError
Else
'did not exist
End If
' Create a new table to hold the transposed data.
' Create a field for each record in the original table.
Set tdfNewDef = db.CreateTableDef(strTarget)
For i = 0 To rstSource.RecordCount
Set fldNewField = tdfNewDef.CreateField(CStr(i + 1), dbText)
tdfNewDef.Fields.Append fldNewField
Next i
db.TableDefs.Append tdfNewDef
' Open the new table and fill the first field with
' field names from the original table.
Set rstTarget = db.OpenRecordset(strTarget)
For i = 0 To rstSource.Fields.Count - 1
With rstTarget
.AddNew
.Fields(0) = rstSource.Fields(i).Name
.Update
End With
Next i
rstSource.MoveFirst
rstTarget.MoveFirst
' Fill each column of the new table
' with a record from the original table.
For j = 0 To rstSource.Fields.Count - 1
' Begin with the second field, because the first field
' already contains the field names.
For i = 1 To rstTarget.Fields.Count - 1
With rstTarget
.Edit
.Fields(i) = rstSource.Fields(j)
rstSource.MoveNext
.Update
End With
Next i
rstSource.MoveFirst
rstTarget.MoveNext
Next j
rstSource.Close
rstTarget.Close
db.Close
Transposer = True
MsgBox "Successfully transposed " & strSource & " to " & strTarget
Exit_Transposer:
If Not rstSource Is Nothing Then Set rstSource = Nothing
If Not rstTarget Is Nothing Then Set rstTarget = Nothing
If Not db Is Nothing Then Set db = Nothing
Exit Function
Transposer_Err:
Transposer = False
Select Case Err
Case 3010
MsgBox "The table " & strTarget & " already exists."
Case 3078
MsgBox "The table " & strSource & " doesn't exist."
Case Else
MsgBox CStr(Err) & " " & Err.Description
End Select
Resume Exit_Transposer
End Function
'***end new code***
