Transpose Query to a Table

[jdlewin1]

Hi static, i can get the transpose from ms access to excel but my issues is with the automation of it so people dont need to do a copy and paste.

 

[static]

You wanted this to generate a report. ?
If a table is auto-generated you wont have an Access report that fits it.
The code I posted creates a report, so why do you need to copy paste?

What sort of report do you need?

 

[jdlewin1]

Hi Static,

The report is an Access report created to display the transposed data with other data which is then saved as PDF reports. These are fully designed / formatted reports.

I need the transposed data to be used in a section of the report.

 

[static]

Ok.

So, the values that will become field names will always be Header, Record1, Record2, etc.

They will never change and there will never be more than 255 of them. And no duplicates.

Correct?

 

[static]

Add a button to a new form. Paste the code into the forms module.
Change table1 to the name of your table/query.

Const tbl As String = "table1"
Const newT As String = tbl & "_copy"

Private Sub Command0_Click()
    numflds = GenTbl
    If numflds Then
        AddRecs numflds
        AddVals
    End If
End Sub

Private Sub AddVals()
    With CurrentDb.OpenRecordset(tbl)
        Do Until .EOF
            For i = 1 To .Fields.Count - 1
                SQL = "update " & newT & " set [" & .Fields(0).Value & "]='" & .Fields(i).Value & "' where [" & .Fields(0).Name & "]='" & .Fields(i).Name & "'"
                CurrentDb.Execute SQL
            Next
            .MoveNext
        Loop
        .Close
    End With
End Sub

Private Sub AddRecs(numflds)
    With CurrentDb.OpenRecordset(tbl)
        For i = 1 To .Fields.Count - 1
            SQL = "insert into " & newT & " values ('" & .Fields(i).Name & "'" & Replace(String(numflds, ","), ",", ",null") & ")"
            CurrentDb.Execute SQL
        Next
        .Close
    End With
End Sub

Private Function GenTbl() As Integer
On Error GoTo errGenTbl
    RefreshDatabaseWindow
    
    With CurrentDb
        .Execute "create table " & newT & " (header text(50))"
        With .OpenRecordset(tbl)
            Do Until .EOF
                CurrentDb.Execute "alter table " & newT & " add [" & .Fields(0).Value & "] text 50"
                .MoveNext
            Loop
            GenTbl = .RecordCount
            .Close
        End With
    End With
    
    RefreshDatabaseWindow
    
errGenTbl:
End Function

 

[jdlewin1]

Hi Static,

Yes thats correct....there will actually only ever be Header, Record1, Record2.....up to Record6. that needs to be fixed so it always has those.

I will look at that code today and see how i get one.

Thanks for your efforts!

 

[jdlewin1]

Hi Static,

The code worked in creating a new table and adding the header column values. It then errors when trying to add the values in the rest of the columns.

The header row also uses the Sample No as the header instead of "Record1","Record2" etc. the sample numbers should be in the first row of the table.

 

[static]

Please upload a sample file (database, not image) to look at, thanks.

 

[jdlewin1]

Attached shows a slimmed version including the query generating the records and then the table with the end result in....

 

[static]

Expected first column to be 'Header'. This should fix it.

...

 

[jdlewin1]

excellent static....no idea what the code does but works great in transposing the data!!

A couple of questions if a may:

1. Is there a way to have the field(column) names as Info, Record1, Record2, Record3, Record4, Record5 and Record6 as in the example table with the field(column) names in the table your code makes in row 1 instead of as the field names?

2. Can this be added to an existing table or does it always need to create a new table?

Cheers,

 

[static]

The code uses the field names to assign values. Once they have been changed it wont work without changing them back again.
I can't be bothered. It's easier to delete the table and recreate it. (I did start adding the code to make the delete optional but have commented it out.)

It now deletes the table automatically and renames the fields once all values are added.

Option Compare Database
Option Explicit

Const tbl As String = "TOA_Report_History"
Const newT As String = tbl & "_copy"

Private Sub Command0_Click()
    Transpose True
End Sub

Private Sub Transpose(mknewtable As Boolean)
    If Not DeleteTable Then Exit Sub
    'If mknewtable Then
        GenTbl
    'Else
    '    CurrentDb.Execute "delete * from [" & newT & "]"
    'End If
    
    AddfieldnamesAsValues
    AddRecs
    AddVals
    RenameFields
End Sub

Private Function DeleteTable() As Boolean
On Error Resume Next
    DoCmd.DeleteObject acTable, newT
    Select Case Err.Number
        Case 0, 7874: DeleteTable = True
        Case 2008: MsgBox "Close table '" & newT & "' and try again."
        Case Else: MsgBox Err.Number & vbNewLine & Err.Description
    End Select
End Function

Private Sub AddfieldnamesAsValues()
    Dim f As DAO.Field
    With CurrentDb.OpenRecordset(newT)
        .addnew
        For Each f In .Fields
            f.Value = f.Name
        Next
        .Update
    End With
End Sub

Private Sub RenameFields()
    Dim db As DAO.Database, td As DAO.TableDef, f As DAO.Field, i
    Set db = CurrentDb
    Set td = db.TableDefs(newT)
    With td
        .Fields(0).Name = "Info"
        For i = 1 To .Fields.Count - 1
            .Fields(i).Name = "Record" & i
        Next
    End With
End Sub

Private Sub AddVals()
    Dim i As Integer, sql As String
    With CurrentDb.OpenRecordset(tbl)
        Do Until .EOF
            For i = 1 To .Fields.Count - 1
                sql = "update " & newT & " set [" & .Fields(0).Value & "]='" & .Fields(i).Value & "' where [" & .Fields(0).Name & "]='" & .Fields(i).Name & "'"
                CurrentDb.Execute sql
            Next
            .MoveNext
        Loop
        .Close
    End With
End Sub

Private Sub AddRecs()
    Dim i As Integer, sql As String, s As String

    With CurrentDb.OpenRecordset(tbl)
        s = Replace(String(CurrentDb.OpenRecordset(newT).Fields.Count - 1, ","), ",", ",null")
        For i = 1 To .Fields.Count - 1
            sql = "insert into " & newT & " values ('" & .Fields(i).Name & "'" & s & ")"
            CurrentDb.Execute sql
        Next
        .Close
    End With
End Sub

Private Function GenTbl() As Integer
On Error GoTo errGenTbl
    Dim hdr As String
    RefreshDatabaseWindow
    
   ' If Not DeleteTable Then Exit Function
    
    With CurrentDb.OpenRecordset(tbl)
        hdr = .Fields(0).Name
    End With
    
    With CurrentDb
        .Execute "create table " & newT & " ([" & hdr & "] text(50))"
        With .OpenRecordset(tbl)
            Do Until .EOF
                CurrentDb.Execute "alter table " & newT & " add [" & .Fields(0).Value & "] text 50"
                .MoveNext
            Loop
            GenTbl = .RecordCount
            .Close
        End With
    End With
    
    RefreshDatabaseWindow
    
errGenTbl:
End Function

 

[jdlewin1]

Hi Static, ok prob easier to do the delete option.

Thank you very much for your help much appreciated!!!