VBA копировать каждые две ячейки и транспонировать

Question

Я пытаюсь создать макрос, который будет транспонировать каждую следующую две ячейки и вставить их в следующие правые ячейки.

У меня есть таблица, как показано на скриншоте:

enter image description here

Я хочу, чтобы мой макрос, чтобы скопировать диапазон "B2:B3" и перенести это "C2", а затем цикл до тех пор, пока некоторые данные в столбце B. (так выберите и скопируйте следующий "B4:B5" и перенесите это на "B4").

Может ли кто-нибудь помочь мне с этим, поскольку я застрял и не могу заставить это транспонировать в нужном месте, а затем цикл.

На данный момент у меня есть что-то вроде этого (я не добавлял цикл еще этот макрос):

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

решение VBA

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

Нет VBA требуется. В C2 входят:

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

и скопировать вниз и в D2 входят:

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

и скопируйте:

и если вам это нужно, как часть некоторых усилий VBA:

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