Converting Row to Column Format

[cantab04]

Hello, I am trying to convert the following table:

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]ID Number[/TD]
[TD]Purchase Amount[/TD]
[TD]Purchase Type[/TD]
[/TR]
[TR]
[TD]23[/TD]
[TD]$86[/TD]
[TD]Product X[/TD]
[/TR]
[TR]
[TD]24[/TD]
[TD]$56[/TD]
[TD]Product Y[/TD]
[/TR]
[TR]
[TD]25[/TD]
[TD]$66[/TD]
[TD]Product X[/TD]
[/TR]
[TR]
[TD]23[/TD]
[TD]$88[/TD]
[TD]Product Y[/TD]
[/TR]
[TR]
[TD]23[/TD]
[TD]$90[/TD]
[TD]Product Z[/TD]
[/TR]
</tbody>[/TABLE]


into this format:

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]ID Number[/TD]
[TD]Purchase Amount 1[/TD]
[TD]Purchase Type 1[/TD]
[TD]Purchase Amount 2[/TD]
[TD]Purchase Type 2[/TD]
[TD]Purchase Amount 3[/TD]
[TD]Purchase Type 3[/TD]
[/TR]
[TR]
[TD]23[/TD]
[TD]$86[/TD]
[TD]Product X[/TD]
[TD]$88[/TD]
[TD]Product Y[/TD]
[TD]$90[/TD]
[TD]Product Z[/TD]
[/TR]
[TR]
[TD]24[/TD]
[TD]$56[/TD]
[TD]Product Y[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]25[/TD]
[TD]$66[/TD]
[TD]Product X[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


Essentially, I need for Excel to recognize instances in which a unique identifier (ID here) is represented on multiple rows, and then convert the data associated with these instances into a Column format.

I have KUTools and have a basic understanding of VBA. Any help is much appreciated!

 

[JoeMo]

This assumes your initial table starts in A1 and rearranges the table starting in E1 of the same worksheet.

Sub RearrangeData()
'assumes initial data headers start in A1 of the active sheet
Dim Rtbl As Range, Rdata As Range, V As Variant, Cols As Long, i As Long, j As Long, nxCol As Long
Set Rtbl = Range("A1").CurrentRegion
Set Rdata = Rtbl.Offset(1, 0).Resize(Rtbl.Rows.Count - 1)
V = Rdata.Value
Application.ScreenUpdating = False
'how many columns needed
Cols = Application.Max(Application.CountIf(Rdata.Columns(1), Rdata.Columns(1)))
'rearrange data starting in E1
Range("E1").Resize(1, 2 * Cols + 1).EntireColumn.ClearContents
Rtbl.Columns(1).AdvancedFilter Action:=xlFilterCopy, copytorange:=[E1], unique:=True
j = 1
For i = 1 To 2 * Cols Step 2
    Range("E1").Offset(0, i) = "Purchase Amount " & j
    Range("E1").Offset(0, i + 1) = "Purchase Type " & j
    j = j + 1
Next i
Range("E1").CurrentRegion.EntireColumn.AutoFit
For Each c In Range("E2:E" & Cells(Rows.Count, "E").End(xlUp).Row)
    For i = LBound(V, 1) To UBound(V, 1)
        If V(i, 1) = c.Value Then
            nxCol = Cells(c.Row, Columns.Count).End(xlToLeft).Column + 1
            Cells(c.Row, nxCol) = V(i, 2)
            Cells(c.Row, nxCol + 1) = V(i, 3)
        End If
        Next i
        nxCol = 0
Next c
Application.ScreenUpdating = True
End Sub

 

[cantab04]

Thank you Joe! I will try this out and report back.