VBA复制每两个单元格和转置

我正在尝试创build一个macros，它将转置每两个单元格并将它们粘贴到下一个正确的单元格中。

我有一个如截图所示的表格：

在这里input图像说明

我想我的macros复制范围"B2:B3"并转置为"C2" ，然后循环，直到B列中有一些数据（所以select和复制下一个"B4:B5"并转置为"B4" ） 。

有人可以帮助我，因为我卡住了，不能得到这个转置在正确的地方，然后循环。

现在我有这样的东西（我没有添加循环，但这个macros）：

 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解决scheme

 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中input：

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

并抄下来在D2中input：

 =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