Try this.

```
Option Explicit
Sub Trans()
Dim I As Long
Dim J As Long
Dim X As Long
Dim arrSrc
Dim arrDst
arrSrc = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value
ReDim arrDst(1 To UBound(arrSrc), 1 To 1)
For I = 1 To UBound(arrSrc)
If IsNumeric(Left(arrSrc(I, 1), 2)) Then
X = X + 1
ReDim Preserve arrDst(1 To UBound(arrSrc), 1 To X)
J = 1
arrDst(J, X) = arrSrc(I, 1)
J = J + 1
Else
arrDst(J, X) = arrSrc(I, 1)
J = J + 1
End If
Next I
Range("B1").Resize(UBound(arrDst, 2), UBound(arrDst)).Value = Application.Transpose(arrDst)
End Sub
```