Sub TransposeData()
Dim sws As Worksheet, dws As Worksheet
Dim slr As Long, c As Long
Dim Rng As Range
Application.ScreenUpdating = False
Set sws = Sheets("Sheet1")
slr = sws.Cells(Rows.Count, 5).End(xlUp).Row
On Error Resume Next
Set dws = Sheets("Output")
dws.Cells.Clear
On Error GoTo 0
If dws Is Nothing Then
Sheets.Add(after:=sws).Name = "Output"
Set dws = ActiveSheet
End If
For Each Rng In sws.Range("E7:E" & slr).SpecialCells(xlCellTypeConstants, 2).Areas
c = c + 1
dws.Cells(1, c).Value = Rng.Cells(1).Offset(-1, -1).Value
Rng.Offset(-1, 0).Resize(Rng.Cells.Count + 1, 1).Copy dws.Cells(2, c)
Next Rng
dws.Rows(1).HorizontalAlignment = xlCenter
Application.ScreenUpdating = True
End Sub
Sub TransposeData()
Dim sws As Worksheet, dws As Worksheet
Dim slr As Long, c As Long, i As Long
Dim Rng As Range
Application.ScreenUpdating = False
Set sws = Sheets("Sheet1")
slr = sws.Cells(Rows.Count, 5).End(xlUp).Row
c = 1
i = 1
For Each Rng In sws.Range("E7:E" & slr).SpecialCells(xlCellTypeConstants, 2).Areas
If c = 1 Then
On Error Resume Next
Set dws = Sheets("Output" & i)
dws.Cells.Clear
On Error GoTo 0
If dws Is Nothing Then
Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Output" & i
Set dws = ActiveSheet
End If
End If
dws.Cells(1, c).Value = Rng.Cells(1).Offset(-1, -1).Value
Rng.Offset(-1, 0).Resize(Rng.Cells.Count + 1, 1).Copy dws.Cells(2, c)
c = c + 1
If c > 10 Then
c = 1
i = i + 1
Set dws = Nothing
End If
Next Rng
Application.ScreenUpdating = True
End Sub
first blank  2 to 13 with the data and all overI know that the first cell in each set will be blank, but will the 2 to 13 part ever have blank cells. If it does do you want to see the blank cells on the right?
I don't care what the output columns are. What should be in the first output column and what should be in the second output column?Please answer that question using this data which is from your workbook.
To see the results, go to Sheet1 and press Ctrl+Shift+S