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
.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
'-----------------
|
Similar Threads
