Copy every two cells and transpose

Question

I am trying to transpose every next two cells and paste them in next right cells.

I have a table as shown in the screenshot:

I want to copy range "B2:B3" and transpose this to "C2" and then loop until there is some data in column B. (so select and copy next "B4:B5" and transpose this to "B4").

I cannot get this to transpose in the right place and then loop.

I have something like this (I did not add loop yet to this macro):

Sub Macro1()
    Dim a As Long, b As Long
    a = ActiveCell.Column
    b = ActiveCell.Row

    Range("B2").Select
    Range(ActiveCell, Cells(b + 1, a)).Select
    Selection.Copy
End Sub

Answer 1

a VBA solution

Option Explicit

Sub main()
    Dim pasteRng As Range
    Dim i As Long

    With ActiveSheet
        Set pasteRng = .Range("C1:D2")
        With .Range("B2:B" & .Cells(.Rows.count, "B").End(xlUp).Row)
            For i = 1 To .Rows.count Step 2
                pasteRng.Offset(i).Value = Application.Transpose(.Cells(i, 1).Resize(2))
            Next i
        End With
    End With
End Sub

Answer 2

No VBA is needed. In C2 enter:

=INDEX(B:B,ROUNDUP(ROWS($1:1)/2,0)*2)

and copy down and in D2 enter:

=INDEX(B:B,ROUNDUP(ROWS($1:1)/2,0)*2+1)

and copy down:

and if you need this as part of some VBA effort:

Sub dural()
    Dim i As Long
    Dim r1 As Range, r2 As Range

    For i = 2 To 10 Step 2
        Set r1 = Range("B" & i & ":B" & (i + 1))
        Set r2 = Range("C" & i)

        r1.Copy

        r2.PasteSpecial Transpose:=True
        r2.Offset(1, 0).PasteSpecial Transpose:=True
    Next i
End Sub