Convert Table to Flat List (maybe macro automate? happy for function ideas)

[Mingalator]

Hi Folks,

I am trying to easily and quickly convert a table with 139 column / headings and variable number of rows, typically ~400, into a flat list of say 3 x 55,600 (139 x 400)

So the headings would be my unique key (project number) then another 138 headings of various categories, say period 1-138

Project	P1	P2	P3	P4	P5	P6
00001	123	234	456	567	678	789
00002	111	222	333	444	555	666

To turn into:

Project	Heading	Value
00001	P1	123
00001	P2	234
00001	P3	456
00001	P4	567
00001	P5	678
00001	P6	789
00002	P1	111
00002	P2	222

Any ideas or pointers would be appreciated, is a macro the way to go?? Or is there a function in Excel that would achieve this?

Thanks

 

[RoryA]

Which version of Office do you have? If you have access to Power Query/Get and Transform, that's just a simple unpivot query.

 

[KOKOSEK]

Without super testing:

Option Explicit

Sub reLayout()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim lastR1 As Integer
Dim lastR2 As Integer
Dim cell As Range
Dim i As Integer

Set sh1 = Sheet1   'original sheet
Set sh2 = Sheet2   'destination sheet - headers should be already there

With sh1
    lastR1 = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

For Each cell In sh1.Range("A2:A" & lastR1)
    For i = 1 To 137
        With sh2
            lastR2 = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
            .Cells(lastR2, 1).Value = cell.Value
            .Cells(lastR2, 2).Value = sh1.Cells(1, i + 1).Value
            .Cells(lastR2, 3).Value = sh1.Cells(cell.Row, i + 1).Value
        End With
    Next i
Next cell
End Sub

 

[Herakles]

I've tested this a bit!!

' Change these two lines.
Set Ws = Worksheets("Project") ' Source of data.
Set WsDestination = Worksheets("ProjectTransformed") ' Destination of data.

Public Sub subTransformData()
Dim Ws As Worksheet
Dim WsDestination As Worksheet
Dim intRow As Integer
Dim intColumns As Integer
Dim intRows As Integer
Dim rng As Range

On Error GoTo Err_Handler

    ActiveWorkbook.Save

    ' Change these two lines.
    Set Ws = Worksheets("Project") ' Source of data.
    Set WsDestination = Worksheets("ProjectTransformed") '  Destination of data.
    
    WsDestination.Cells.ClearContents
    WsDestination.Range("A1:C1").Value = Array("Project", "Heading", "Value")
        
    intColumns = Ws.Range("A1").CurrentRegion.Columns.Count - 1
    intRows = Ws.Range("A1").CurrentRegion.Rows.Count
    intRow = 2
    
    For Each rng In Ws.Range("A2").Resize(intRows - 1, 1).Cells
        With WsDestination
            .Cells(intRow, 1).Resize(intColumns, 1).Value = rng.Value
            .Cells(intRow, 2).Resize(intColumns, 1).Value = Application.WorksheetFunction.Transpose(Ws.Range("B1").Resize(1, intColumns))
            .Cells(intRow, 3).Resize(intColumns, 1).Value = Application.WorksheetFunction.Transpose(rng.Offset(0, 1).Resize(1, intColumns))
        End With
        intRow = intRow + intColumns
    Next rng
              
Exit_Handler:

    Exit Sub

Err_Handler:

    MsgBox "There has been an error, the data may not have been transformed correcty.", vbInformation, "Warning!"

    Resume Exit_Handler

End Sub

 

[Mingalator]

Which version of Office do you have? If you have access to Power Query/Get and Transform, that's just a simple unpivot query.

Thanks Rory, I am on 365, which I am assuming should get access to Power Query?

 

[Mingalator]

Which version of Office do you have? If you have access to Power Query/Get and Transform, that's just a simple unpivot query.

Just looked this up and this is a really handy function, many thanks

 

[Mingalator]

Without super testing:

Option Explicit

Sub reLayout()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim lastR1 As Integer
Dim lastR2 As Integer
Dim cell As Range
Dim i As Integer

Set sh1 = Sheet1   'original sheet
Set sh2 = Sheet2   'destination sheet - headers should be already there

With sh1
    lastR1 = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

For Each cell In sh1.Range("A2:A" & lastR1)
    For i = 1 To 137
        With sh2
            lastR2 = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
            .Cells(lastR2, 1).Value = cell.Value
            .Cells(lastR2, 2).Value = sh1.Cells(1, i + 1).Value
            .Cells(lastR2, 3).Value = sh1.Cells(cell.Row, i + 1).Value
        End With
    Next i
Next cell
End Sub

Thank you for the reply, using RoryA's suggestion of the Power Query Unpivot has solved it for me, thanks for the help though.

 

[Mingalator]

I've tested this a bit!!

' Change these two lines.
Set Ws = Worksheets("Project") ' Source of data.
Set WsDestination = Worksheets("ProjectTransformed") ' Destination of data.

Public Sub subTransformData()
Dim Ws As Worksheet
Dim WsDestination As Worksheet
Dim intRow As Integer
Dim intColumns As Integer
Dim intRows As Integer
Dim rng As Range

On Error GoTo Err_Handler

    ActiveWorkbook.Save

    ' Change these two lines.
    Set Ws = Worksheets("Project") ' Source of data.
    Set WsDestination = Worksheets("ProjectTransformed") '  Destination of data.
   
    WsDestination.Cells.ClearContents
    WsDestination.Range("A1:C1").Value = Array("Project", "Heading", "Value")
       
    intColumns = Ws.Range("A1").CurrentRegion.Columns.Count - 1
    intRows = Ws.Range("A1").CurrentRegion.Rows.Count
    intRow = 2
   
    For Each rng In Ws.Range("A2").Resize(intRows - 1, 1).Cells
        With WsDestination
            .Cells(intRow, 1).Resize(intColumns, 1).Value = rng.Value
            .Cells(intRow, 2).Resize(intColumns, 1).Value = Application.WorksheetFunction.Transpose(Ws.Range("B1").Resize(1, intColumns))
            .Cells(intRow, 3).Resize(intColumns, 1).Value = Application.WorksheetFunction.Transpose(rng.Offset(0, 1).Resize(1, intColumns))
        End With
        intRow = intRow + intColumns
    Next rng
             
Exit_Handler:

    Exit Sub

Err_Handler:

    MsgBox "There has been an error, the data may not have been transformed correcty.", vbInformation, "Warning!"

    Resume Exit_Handler

End Sub

Thank you for the reply, using RoryA's suggestion of the Power Query Unpivot has solved it for me, thanks for the help though.

 

[RoryA]

Just looked this up and this is a really handy function, many thanks

Glad we could help. You might want to update your profile here to show you have 365 as it will help people assisting you to know what functions you have available to you.