Originally Posted by Ben McClave

LearningHorse,

Here's another take on the transpose macro. This one will not require any special setup to run. Simply paste the code below into a module in your workbook, select the range containing your data or alter the code to hard-code a range (for example, "A1:Y6") and run the macro. The end result should be a sorted list that looks very similar to the sample you provided beginning three rows below the selected data.

Ben

Sub TransposeAll()
Dim rTrans As Range
Dim i As Long
Dim j As Long
Dim x As Long
Dim sRows As String

Application.ScreenUpdating = False

Set rTrans = Selection 'Or specify the range

With rTrans
i = .Columns.Count
j = .Rows.Count
.Copy
.Range("A1").Offset(j + 3, 1).PasteSpecial Paste:=xlPasteAll, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End With

Set rTrans = rTrans.Range("A1").Offset(j + 3, 1)
Set rTrans = rTrans.Resize(i, 1)

For x = 1 To j
Select Case x
Case 1
rTrans.Range("A1").Clear
sRows = rTrans.Range("A1").Row & ":" & rTrans.Range("A1").Row
Case 2
rTrans.Offset(0, -1).Value = _
rTrans.Range("A1").Offset(0, 1).Value
rTrans.Range("A1").Offset(0, 1).Clear
rTrans.Range("A1").Offset(0, -1).Clear
Case Else
rTrans.Copy rTrans.Offset((x - 2) * i, 0)
rTrans.Offset((x - 2) * i, -1).Value = _
rTrans.Range("A1").Offset(0, x - 1).Value
rTrans.Offset((x - 2) * i, 1).Value = _
rTrans.Offset(0, x - 1).Value
sRows = sRows & ", " & rTrans.Offset((x - 2) * i, 0).Row & ":" & _
rTrans.Offset((x - 2) * i, 0).Row
End Select
Next x

Range(sRows).EntireRow.Delete
Set rTrans = rTrans.Offset(0, 2)
Set rTrans = rTrans.Resize(i, j - 2)
rTrans.Clear

Set rTrans = rTrans.Offset(0, -3).Resize((i * (j - 1)) - j + 1, 3)
SortMe ActiveSheet, rTrans
rTrans.Activate
Set rTrans = Nothing
Application.ScreenUpdating = True
End Sub
Sub SortMe(ws As Worksheet, rSort As Range)
With ws.Sort
.SortFields.Clear
.SortFields.Add Key:=rSort.Columns(1) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=rSort.Columns(2) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rSort
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub