View Single Post
 
Old January 31st, 2005, 07:55 AM
penta penta is offline
Friend of Wrox
 
Join Date: Aug 2004
Location: , , .
Posts: 159
Thanks: 0
Thanked 0 Times in 0 Posts
Default

I am sending u the code from the link:

Transpose table access 2002
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), 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
   db.Close
  Exit Function
 Transposer_Err:
   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
     Exit Function
 End Function

                              On-line help from Microsoft
            30/01/2005