Чередующиеся строки столбца перевести в столбцы (Microsoft Office Excel)

Sub someShit()
    Dim r As Range
    Dim i As Integer, j As Integer
    Dim counter As Integer: counter = 0
    Dim c As Integer
    Set r = Nothing
    j = 1: i = 2: prevC = 0
    While Cells(i, "A") <> vbNullString
        c = Application.WorksheetFunction.CountIf(Range("A2:A" & i), Cells(i, "A"))
        If c = counter Then
            If r Is Nothing Then
                Set r = Cells(i, "A")
            Else
                Set r = Union(r, Cells(i, "A"))
            End If
        Else
            If Not r Is Nothing Then
                Cells(j, "H").Resize(1, r.Cells.Count).Value = Application.Transpose(r.Value)
            End If
            Set r = Cells(i, "A")
            j = j + 1
            counter = c
        End If
        i = i + 1
    Wend
    Cells(j, "H").Resize(1, r.Cells.Count).Value = Application.Transpose(r.Value)
End Sub