Format Table into Columns

bluelabel

Board Regular
Joined
Nov 27, 2008
Messages
76
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
QWEASDZXCRTY
ABC102030
DEF4050
GHI607080
JKL90100

<tbody>
</tbody>

Formatted Data
Head 1
Head 2
Head 3
ABC10QWE
ABC20ZXC
ABC30RTY
DEF40ASD
DEF50ZXC
GHI60QWE
GHI70ZXC
GHI80RTY
JKL90ASD
JKL100RTY

<tbody>
</tbody>

Is there a way to do this in VBA?
 

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.

nemmi69

Active Member
Joined
Mar 15, 2012
Messages
482
Office Version
  1. 365
  2. 2016
  3. 2013
Platform
  1. Windows
Try this

Code:
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
59,929
Office Version
  1. 365
Platform
  1. Windows
Another option
Code:
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.
 

Forum statistics

Threads
1,136,341
Messages
5,675,203
Members
419,553
Latest member
hanahass

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top