Transpose unequal excel columns to rows

Question

I have received an Excel table with different number of items per category:

Category A   Category B   Category C
22           11           1
34           15           6
55           4            18
33
36

I'd like to turn this into:

Category     Item
Category A   22
Category A   34
Category A   55
Category A   33
Category A   36
Category B   11
Category B   15
[...]

What is a quick way of achieving this?

score 1 · Accepted Answer · answered Oct 03 '12 at 17:57

A macro will do that easily. The macro below will put the result in a new worksheet.

Sub TransposeStuff()
Dim lLastRow As Long, lColLoop As Long, lLastCol As Long
Dim shtOrg As Worksheet, shtDest As Worksheet

'turn off updates to speed up code execution
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
End With


Set shtOrg = ActiveSheet
Set shtDest = Sheets.Add

shtDest.[a1] = "Category"
shtDest.[B1] = "Item"

lLastCol = shtOrg.Cells(1, Columns.Count).End(xlToLeft).Column


For lColLoop = 1 To lLastCol
    lLastRow = shtOrg.Cells(Rows.Count, lColLoop).End(xlUp).Row

    shtOrg.Range(shtOrg.Cells(2, lColLoop), shtOrg.Cells(lLastRow, lColLoop)).Copy
        shtDest.Cells(Rows.Count, 2).End(xlUp).Offset (1)

    shtDest.Range(shtDest.Cells(Rows.Count, 1).End(xlUp).Offset(1), _
                    shtDest.Cells(Rows.Count, 2).End(xlUp).Offset(, -1)).Value = shtOrg.Cells(1, lColLoop)

Next lColLoop

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With

End Sub

Transpose unequal excel columns to rows

1 Answers1