converting table to list

Question

I often face this problem. I hope I can get some useful way to do it in this forum

I need to convert table to list

Ex. here is the table I want to convert

	A	B	C
abc	43	21	3
xyz	3	1	43
pqrs	123	34	0

Following is the result using macro mentioned at the end.

Column1	Column2	Column3
abc	A	43
abc	B	21
abc	C	3
xyz	A	3
xyz	B	1
xyz	C	43
pqrs	A	123
pqrs	B	34
pqrs	C	0

The problem is where I have column title in multiple rows or more than one row to repeat in multiple columns. Scrip I use is good for only one row for column headers and one column for row description.

Can someone help me on this.

---

Macro I used (copied from internet.)

Sub ashish()

'   Before running this, make sure you have a summary table with column headers.

'   The output table will have three columns.

    Dim SummaryTable As Range, OutputRange As Range

    Dim OutRow As Long

    Dim r As Long, c As Long

    On Error Resume Next

    Set SummaryTable = ActiveCell.CurrentRegion

    If SummaryTable.Count = 1 Or SummaryTable.Rows.Count < 3 Then

        MsgBox "Select a cell within the summary table.", vbCritical

        Exit Sub

    End If

    SummaryTable.Select

    Set OutputRange = Application.InputBox(prompt:="Select a cell for the 3-column output", Type:=8)

'   Convert the range

    OutRow = 2

    Application.ScreenUpdating = False

    OutputRange.Range("A1:C3") = Array("Column1", "Column2", "Column3")

    For r = 2 To SummaryTable.Rows.Count

        For c = 2 To SummaryTable.Columns.Count

            OutputRange.Cells(OutRow, 1) = SummaryTable.Cells(r, 1)

            OutputRange.Cells(OutRow, 2) = SummaryTable.Cells(1, c)

            OutputRange.Cells(OutRow, 3) = SummaryTable.Cells(r, c)

            OutputRange.Cells(OutRow, 3).NumberFormat = SummaryTable.Cells(r, c).NumberFormat

            OutRow = OutRow + 1

        Next c

    Next r

End Sub

Answer 1

Hi,

try this,

Sub ConvertData_02()

'Oct 31, 2014

Const nH As Long = 2 '<< number of headers

Const N As Long = 3 '<<< data starts in row 3

Dim ws As Worksheet

Set ws = Sheets("Sheet1") '<< source sheet

Dim r As Long, c As Long, x As Long, t As Long

r = ws.Cells(Rows.Count, "A").End(xlUp).Row

c = ws.Cells(1, Columns.Count).End(xlToLeft).Column

Application.ScreenUpdating = False

Sheets.Add

t = 1

For x = 3 To c

ws.Range("A" & N).Resize(r - nH, 2).Copy

Cells(t, "A").PasteSpecial xlPasteValues

ws.Cells(1, x).Resize(nH).Copy

Cells(t, "c").Resize(r - nH).PasteSpecial xlPasteValues, Transpose:=True

ws.Cells(N, x).Resize(r - nH).Copy

Cells(t, nH + 3).PasteSpecial xlPasteValues

t = Cells(Rows.Count, "A").End(xlUp).Row + 1

Next

Application.CutCopyMode = False

[A1].Select

ActiveSheet.UsedRange.EntireColumn.AutoFit

Application.ScreenUpdating = True

End Sub

here..

Answer 2

Hi,

a simple sample with duplicate or triple data and expected results could help.

Answer 3

I already  have this solution. Script that is use is already there in the original question. 

The problem is when I have column title in multiple rows or more than one row to repeat in multiple columns. Scrip I use is good for only one row for column headers and one column for row description.

Answer 4

Hi,

try this code

expected results in a new sheet

Sub a_001()

Const N As Long = 2 '<<< source sheet: data starts in row 2

Dim ws As Worksheet

Set ws = Sheets("Sheet1") '<< source sheet name, change

Dim r As Long, x As Long, t As Long

r = ws.Cells(Rows.Count, "A").End(xlUp).Row

Application.ScreenUpdating = False

Sheets.Add

t = 1

For x = N To r

ws.Cells(x, "A").Copy

Cells(t, "A").Resize(3).PasteSpecial xlPasteValues, Transpose:=True

ws.Cells(1, "B").Resize(, 3).Copy

Cells(t, "B").Resize(3).PasteSpecial xlPasteValues, Transpose:=True

ws.Cells(x, "B").Resize(, 3).Copy

Cells(t, "C").Resize(3).PasteSpecial xlPasteValues, Transpose:=True

t = Cells(Rows.Count, "A").End(xlUp).Row + 1

Next

Application.CutCopyMode = False

ActiveSheet.UsedRange.EntireColumn.AutoFit

[A1].Select

Application.ScreenUpdating = True

End Sub

sample..

Answer 5

I feel it could be an easy fix for someone having good knowledge of VB. Can someone make the change to the script and share here.