Problems transposing a table (columns into rows, with column headings)

[LondonExcel]

Having read what seems like hundreds of forum posts about using a macro to transpose data from columns into rows, I still haven't managed to get my macro to work.

I need to go from this:

		1	2	3	4
Category A	Record 1	B	C	D	E
Category A	Record 2	C	D	E
Category B	Record 3	C			A
Category B	Record 4			A

<tbody>
</tbody>

To this:

Category A
Record 1
1	B
2	C
3	D
4	E
Record 2
1	C
2	D
3	E
Category B
Record 3
1	C
4	A
Record 4
3	A

<tbody>
</tbody>

Here's what I have so far:

Sub TransposeColumnsToRows()


Dim sourceCell As Range
Dim destCell As Range
Dim lastRowInDestCol As Range
Dim category As String


category = Sheets("Source data").Range("A2")
Sheets("Source data").Range("L1") = category

Do While Sheets("Source data").Range("A2").Value <> ""

If category <> Sheets("Source data").Range("A2") Then

'Select first row and header row
    Sheets("Source data").Range("A1:J2").Select
'Copy first row and header row
    Selection.Copy
'Select pasting location
    Sheets("Source data").Range("L2").Select

Else

'Select all but the category column
    Sheets("Source data").Range("B1:J2").Select
'Copy first row and header row
    Selection.Copy

End If

lastRowInDestCol = Range("J" & Rows.Count).End(xlUp).Row + 1

'Select first empty row in destination column
    Range("J" & lastRowInDestCol).Select

'Paste with transpose
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=True

'Select and delete row that was just transposed
    Sheets("Source data").Range("A2:J2").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp

Loop

End Sub

Any thoughts/suggestions on how best to achieve this?

 

[LondonExcel]

That works brilliantly, thank you so much!