Transpose - change heading names of fields 1

[micang]

Access 2003

Hi All,

I got this code off the MS website. It transposes data from a query or table into a new table.

I have it working fine, but I am not too familiar with VBA and I was wondering if it would be possible to have the heading names of the fields in the table that it creates, changed?

By default it names them "1","2" etc.

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

Any info really appreciated.

Michael

 

[Remou]

This:

[tt]Set fldNewField = tdfNewDef.CreateField(CStr(i + 1), dbText)[/tt]

Is the line that names the fields. You can edit it, or you can rename the fields after the table has bee created:

Dim db As Database
Dim tdf As DAO.TableDef

Set db = CurrentDb
Set tdf = db.TableDefs("Table1")

tdf.Fields(1).Name = "NewName"

 

[micang]

Remou, brilliant, perfect.

Thank you very much.

Michael