Format Table into Columns

[bluelabel]

Hi Team,

I have a bunch of data in a table that I need into a column set up as per the below.

Base Data
[TABLE="class: grid, width: 250, align: center"]
<tbody>[TR]
[TD][/TD]
[TD]QWE[/TD]
[TD]ASD[/TD]
[TD]ZXC[/TD]
[TD]RTY[/TD]
[/TR]
[TR]
[TD]ABC[/TD]
[TD]10[/TD]
[TD][/TD]
[TD]20[/TD]
[TD]30[/TD]
[/TR]
[TR]
[TD]DEF[/TD]
[TD][/TD]
[TD]40[/TD]
[TD]50[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]GHI[/TD]
[TD]60[/TD]
[TD][/TD]
[TD]70[/TD]
[TD]80[/TD]
[/TR]
[TR]
[TD]JKL[/TD]
[TD][/TD]
[TD]90[/TD]
[TD][/TD]
[TD]100[/TD]
[/TR]
</tbody>[/TABLE]

Formatted Data
[TABLE="class: grid, width: 250, align: center"]
<tbody>[TR]
[TD]Head 1
[/TD]
[TD]Head 2
[/TD]
[TD]Head 3
[/TD]
[/TR]
[TR]
[TD]ABC[/TD]
[TD]10[/TD]
[TD]QWE[/TD]
[/TR]
[TR]
[TD]ABC[/TD]
[TD]20[/TD]
[TD]ZXC[/TD]
[/TR]
[TR]
[TD]ABC[/TD]
[TD]30[/TD]
[TD]RTY[/TD]
[/TR]
[TR]
[TD]DEF[/TD]
[TD]40[/TD]
[TD]ASD[/TD]
[/TR]
[TR]
[TD]DEF[/TD]
[TD]50[/TD]
[TD]ZXC[/TD]
[/TR]
[TR]
[TD]GHI[/TD]
[TD]60[/TD]
[TD]QWE[/TD]
[/TR]
[TR]
[TD]GHI[/TD]
[TD]70[/TD]
[TD]ZXC[/TD]
[/TR]
[TR]
[TD]GHI[/TD]
[TD]80[/TD]
[TD]RTY[/TD]
[/TR]
[TR]
[TD]JKL[/TD]
[TD]90[/TD]
[TD]ASD[/TD]
[/TR]
[TR]
[TD]JKL[/TD]
[TD]100[/TD]
[TD]RTY[/TD]
[/TR]
</tbody>[/TABLE]

Is there a way to do this in VBA?

 

[nemmi69]

Try this

Dim LastRowNo As Long
Dim LastColNo As Long
Dim Rloop As Long
Dim Cloop As Long
Dim Rcount As Integer
Dim Ccount As Integer
Dim NewTableRSt As Integer
Dim NewTableCSt As Integer


Sub SortTable()
Rcount = 1
Ccount = 0
'where new table will start
NewTableRSt = 10
NewTableCSt = 1


LastRowNo = Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
LastColNo = Worksheets("Sheet1").Cells(2, Columns.Count).End(xlToLeft).Column
For Rloop = 3 To LastRowNo


    For Cloop = 2 To LastColNo
        If Trim(Worksheets("Sheet1").Cells(Rloop, Cloop).Value) <> "" Then
            Worksheets("Sheet1").Cells(NewTableRSt + Rcount, NewTableCSt + Ccount).Value = Worksheets("Sheet1").Cells(Rloop, 1).Value
            Ccount = Ccount + 1
            Worksheets("Sheet1").Cells(NewTableRSt + Rcount, NewTableCSt + Ccount).Value = Worksheets("Sheet1").Cells(Rloop, Cloop).Value
            Ccount = Ccount + 1
            Worksheets("Sheet1").Cells(NewTableRSt + Rcount, NewTableCSt + Ccount).Value = Worksheets("Sheet1").Cells(2, Cloop).Value
            Ccount = 0
            Rcount = Rcount + 1
        End If
    Next Cloop
    Ccount = 0
Next Rloop


End Sub

 

[Fluff]

Another option

Sub Convertdata()
   Dim ary As Variant, Nary As Variant
   Dim r As Long, c As Long, rr As Long, cc As Long
   
   ary = Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To Application.CountA(ary), 1 To 3)
   For r = 2 To UBound(ary)
      For c = 2 To UBound(ary, 2)
         If Not IsEmpty(ary(r, c)) Then
            rr = rr + 1
            Nary(rr, 1) = ary(r, 1)
            Nary(rr, 2) = ary(r, c)
            Nary(rr, 3) = ary(1, c)
         End If
      Next c
   Next r
   Range("H1:J1").Value = Array("Head 1", "Head 2", "Head3")
   Range("H2").Resize(rr, 3).Value = Nary
End Sub

You may need to change the output range.