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?

 

[texasalynn]

here is one way

Sub Transpose_Category()
Dim LR As Long, i As Long, j As Long, ALR As Long
LR = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row 'get last row column A
LC = ActiveSheet.Range("IV" & 1).End(xlToLeft).Column
For i = 2 To LR
    ALR = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
    For j = 1 To LC
        If j < 3 Then
            Cells(ALR, "A") = Cells(i, j)
            ALR = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
        Else
            If Cells(i, j) <> "" Then
                Cells(ALR, "A") = Cells(1, j)
                Cells(ALR, "B") = Cells(i, j)
                ALR = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
            End If
        End If
    Next j
Next i
MsgBox "Transpose is complete"
End Sub

 

[p45cal]

or:

Sub blah()
Hdrs = Application.Transpose(Range("C1:J1"))
For Each cll In Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))  'assumes nothing below table to transpose
  Set dest = Cells(Rows.Count, "L").End(xlUp).Offset(1)
  If cll.Value <> Cat Then  'don't repeat Category if it's the same.
    Cat = cll.Value
    dest.Value = Cat
    Set dest = dest.Offset(1)
  End If
  dest.Value = cll.Offset(, 1).Value
  Set dest = dest.Offset(1).Resize(UBound(Hdrs))
  dest.Value = Hdrs
  dest.Offset(, 1).Value = Application.Transpose(cll.Offset(, 2).Resize(, UBound(Hdrs)).Value)
  On Error Resume Next
  Intersect(dest.Offset(, 1).SpecialCells(xlCellTypeBlanks).EntireRow, Range("L:M")).Delete Shift:=xlUp
  On Error GoTo 0
Next cll
End Sub

Uses columns A:J as source as determined by your code, destination columns L:M of the same sheet, works on the active sheet.

 

[LondonExcel]

Thank you p45cal! This also looks good but none of the variables are declared so I keep getting errors on Hdrs, cll, dest, etc...

 

[LondonExcel]

TexasAlynn: This works perfectly, and I am infinitely grateful for your help! Unfortunately, I don't quite understand the method you've used though so I would have trouble adopting this macro for other purposes. Is there any way you could give a bit of detail about what each part does?<deleted></deleted>

 

[LondonExcel]

<deleted>

 

[LondonExcel]

Actually texasalynn, I just realised that the category column is being repeated for each "record" that is transposed. Is there a way to make it so that the category only appears when there is a new category? Thanks in advance!

 

[texasalynn]

see if this works

Sub Transpose_Category()
Dim LR As Long, i As Long, j As Long, ALR As Long
LR = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row 'get last row column A
LC = ActiveSheet.Range("IV" & 1).End(xlToLeft).Column
For i = 2 To LR ' loop through all rows
    ALR = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
    For j = 1 To LC ' loop through all columns on current row
        If j = 1 And Cells(i, 1) <> Cells(i - 1, 1) Then 'check category
            Cells(ALR, "A") = Cells(i, j)
            ALR = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
        End If
        If j = 2 Then 'get record number
                Cells(ALR, "A") = Cells(i, j)
                ALR = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
        End If
        If Cells(i, j) <> "" And j > 2 Then 'process the 1-4 items
            Cells(ALR, "A") = Cells(1, j)
            Cells(ALR, "B") = Cells(i, j)
            ALR = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
        End If
    Next j
Next i
MsgBox "Transpose is complete"
End Sub

 

[p45cal]

Thank you p45cal! This also looks good but none of the variables are declared so I keep getting errors on Hdrs, cll, dest, etc...

So declare them!
Either take out Option Explicit from the top of the module or add the following line after the Sub line:
Dim Hdrs, cll As Range, dest As Range, Cat

 

[LondonExcel]

Thanks, that worked perfectly when I took out Option Explicit, but it did take a very long time with nearly 20 thousand rows!