Transpose Excel column to rows

Question

I have an Excel sheet that looks like the first picture and I want to convert it to the second picture:

I have written the following code but it does not work as ex

Answer 1

Shank, using your code, I've made minor modifications and now it deletes the right number of rows and it works, try it out.

Sub Transpose()

Dim sht As Worksheet
Dim LastRow As Long

Set sht = ThisWorkbook.Worksheets("Sheet_Name") ' modify here to your Worksheet name
LastRow = sht.Cells(sht.Rows.count, "A").End(xlUp).row

    For row = 1 To LastRow
        If sht.Cells(row, 1) <> "" Then
            i = i + 1
            j = i
            Z = 1
            Do While Cells(j + 1, 1).Value = Cells(j, 1).Value
                j = j + 1
            Loop

            Set rng2 = Range("B" & i & ":B" & j)

            If i > 1 Then
                Z = j - i + 1
            Else
                Z = j
            End If

            rng2.Resize(Z).Copy
            Range("C" & i).PasteSpecial Transpose:=True
            T = i

            Do While j - row > 0
                Q = T + 1
                Rows(Q).EntireRow.Delete
                j = j - 1
            Loop
        End If
    Next

End Sub