Transpose Row with mutiple columns to Column with single row

[brendanolear]

Hi,

I am trying to convert a table in the following way. Is there a way to realise this using a make table query?

Name	WK1	WK2	WK3	WK4	WK5	WK6
Tom	100	100	100	100	100	100
Bill	25	25	25	25
Jack			33	33	33	33
Name	Week	Total
Tom	WK1	100
Tom	WK2	100
Tom	WK3	100
Tom	WK4	100
Tom	WK5	100
Tom	WK6	100
Bill	WK1	25
Bill	WK2	25
Bill	WK3	25
Bill	WK4	25
Tom	WK3	33
Tom	WK4	33
Tom	WK5	33
Tom	WK6	33

<colgroup><col width="64" style="width: 48pt;" span="7"> <tbody> </tbody>

 

[Joe4]

Glad to see that you are normalizing your table. Smart move!

Quite frankly, I think the easiest way (at least for me) is to export to Excel, change the structure there, and re-import to Access.

 

[brendanolear]

Thanks Joe thought that may have been the case.

 

[xenou]

sql-wise you would write an insert statement for each column (which would be a little ugly but not as bad as it sounds since you can just do some copy pasting and the only thing really changing is the column name).

You could write a script for this if it's a regular thing but getting it into a normalized table will be good and just a one off thing in that case.

Edit: note that you will have to think about how you want to treat the null/blank values (i.e.Bill weeks 5 and 6 and Jack weeks 1 and 2) - based on your example output it sounds like you want to not include them (this however means that reports that need to show all weeks for Bill or Jack will require some additional steps to show the "missing" weeks).

 

[Joe4]

Here is some Excel VBA code I whipped up for you that should do it, based on your sample data. I documented it to explain what each step does.

Sub TransposeData()

    Dim ss As Worksheet
    Dim ds As Worksheet
    Dim lastCol As Long
    Dim lastRow As Long
    Dim recNum As Long
    Dim myCol As Long
    Dim myRow As Long
    Dim myName As String
    Dim myWeek As String
    Dim myNum As Double
    
    Application.ScreenUpdating = False
    
'   Set source and destination sheets
    Set ss = Sheets("Sheet1")
    Set ds = Sheets("Sheet2")
    
'   Find last row and column on sheet
    lastCol = ss.Cells(1, Columns.Count).End(xlToLeft).Column
    lastRow = ss.Cells(Rows.Count, "A").End(xlUp).Row
    
'   Add titles to destination sheet
    ds.Range("A1") = "Name"
    ds.Range("B1") = "Week"
    ds.Range("C1") = "Total"
    
    recNum = 1
    
'   Loop through all rows starting in row 2
    For myRow = 2 To lastRow
'       Get name
        myName = ss.Cells(myRow, "A")
'       Loop through all columns starting in column 2
        For myCol = 2 To lastCol
'           Check to see if any value (if they do, add entry)
            If ss.Cells(myRow, myCol) <> 0 Then
'               Get values
                myWeek = ss.Cells(1, myCol)
                myNum = ss.Cells(myRow, myCol)
'               Write to destination sheet
                recNum = recNum + 1
                ds.Cells(recNum, "A") = myName
                ds.Cells(recNum, "B") = myWeek
                ds.Cells(recNum, "C") = myNum
            End If
        Next myCol
    Next myRow
    
    Application.ScreenUpdating = True
                
    MsgBox "Process complete!"
                
End Sub