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

	QWE	ASD	ZXC	RTY
ABC	10		20	30
DEF		40	50
GHI	60		70	80
JKL		90		100

<tbody>
</tbody>

Formatted Data

Head 1	Head 2	Head 3
ABC	10	QWE
ABC	20	ZXC
ABC	30	RTY
DEF	40	ASD
DEF	50	ZXC
GHI	60	QWE
GHI	70	ZXC
GHI	80	RTY
JKL	90	ASD
JKL	100	RTY

<tbody>
</tbody>

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.