Transpose Columns to Rows by blank - vba

Question

I need to transpose vertical data from column B to horizontal data.
My table looks like this:
85.98 | | | | | |
-------|--------|--------|--------|--------|--------|
97.62 | | | | | |
-------|--------|--------|--------|--------|--------|
100.00 | | | | | |
-------|--------|--------|--------|--------|--------|
100.00 | | | | | |
-------|--------|--------|--------|--------|--------|
| | | | | |
-------|--------|--------|--------|--------|--------|
89.81 | | | | | |
-------|--------|--------|--------|--------|--------|
78.70 | | | | | |
-------|--------|--------|--------|--------|--------|
100.00 | | | | | |
-------|--------|--------|--------|--------|--------|
| | | | | |
-------|--------|--------|--------|--------|--------|
94.32 | | | | | |
-------|--------|--------|--------|--------|--------|
| | | | | |
-------|--------|--------|--------|--------|--------|
| | | | | |
-------|--------|--------|--------|--------|--------|
| | | | | |
-------|--------|--------|--------|--------|--------|
90.91 | | | | | |
-------|--------|--------|--------|--------|--------|
0.00 | | | | | |
-------|--------|--------|--------|--------|--------|
88.54 | | | | | |
-------|--------|--------|--------|--------|--------|
76.96 | | | | | |
-------|--------|--------|--------|--------|--------|
94.32 | | | | | |
-------|--------|--------|--------|--------|--------|
89.11 | | | | | |
-------|--------|--------|--------|--------|--------|
And I want it to look like this:
85.98 | 97.62 | 100.00 | 100.00 | | |
-------|--------|--------|--------|--------|--------|
89.81 | 78.70 | 100.00 | | | |
-------|--------|--------|--------|--------|--------|
94.32 | | | | | |
-------|--------|--------|--------|--------|--------|
| | | | | |
-------|--------|--------|--------|--------|--------|
90.91 | 0.00 | 88.54 | 76.96 | 94.32 | 89.11 |
I am using the following code:
Sub Transpose()
Dim t As Range, u As Range
c = ActiveCell.Column
fr = ActiveCell.Row
lr = Cells(Rows.Count, c).End(xlUp).Row
r = fr
Do
Set t = Cells(r, c)
Set u = t.End(xlDown)
Range(t, u).Copy
t.Offset(, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
r = u.End(xlDown).Row
Loop While r < lr
Application.CutCopyMode = False
End Sub
The problem is .End(xlDown) doesn't work because there are single rows of data. Is there a solution for this?

Answer 1

What you are trying to achieve can be accomplished with this...
Sub TransposeData()
Dim lr As Long
Dim rng As Range
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 3).End(xlUp).Row
'Change the first row as required. C1 in the below line assumes that the data start from Row1 in Column C.
For Each rng In Range("C1:C" & lr).SpecialCells(xlCellTypeConstants, 1).Areas
rng.Copy
rng.Cells(1).Offset(0, 1).PasteSpecial xlPasteAll, Transpose:=True
Next rng
Application.CutCopyMode = 0
Application.ScreenUpdating = True
End Sub