A takto?

Sub ToOneColumn()
    Dim i As Long, k As Long, j As Integer
    Application.ScreenUpdating = False
    Columns(1).Insert
    i = 0
    k = 1
    While Not IsEmpty(Cells(k, 2))
        j = 2
        While Not IsEmpty(Cells(k, j))
            i = i + 1
            Cells(i, 1) = Cells(k, j)
            Cells(k, j).Clear
            j = j + 1
        Wend
        k = k + 1
    Wend
    Application.ScreenUpdating = True
End Sub