View Single Post
Old January 31st, 2005, 12:49 PM
JpJoe JpJoe is offline
Friend of Wrox
Join Date: Jan 2005
Location: , , United Kingdom.
Posts: 100
Thanks: 0
Thanked 0 Times in 0 Posts

Hmmm. I have tried to run that function an it is fine!

Have you had to modify the function in any way??? If not paste the following duplicate into a new module and run the TransposeTable sub below.


Sub TransposeTable()
    Transposer "suppliers", "tbl_New_Suppliers"
End Sub

Function Transposer(strSource As String, strTarget As String)
 Dim db As DAO.Database
 Dim tdfNewDef As DAO.TableDef
 Dim fldNewField As DAO.Field
 Dim rstSource As DAO.Recordset, rstTarget As DAO.Recordset
 Dim i As Integer, j As Integer

 On Error GoTo Transposer_Err

 Set db = CurrentDb()
 Set rstSource = db.OpenRecordset(strSource)

 rstSource.MoveLast ' 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), dbMemo)
     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
        .Fields(0) = rstSource.Fields(i).Name
      End With
 Next i
 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
        .Fields(i) = rstSource.Fields(j)
      End With
   Next i
 Next j
  Exit Function
   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) & " " & _
       End Select
     Exit Function
 End Function