复制每两个单元格并进行转置

Question

我试图将每个接下来的两个细胞移植到下一个细胞中。

我有一张表格，如截图所示：

我想要复制范围"C2"并将其转置为"B4:B5"，然后循环直到B列中有一些数据。（因此请选择并复制下一个"B4"并将其转置为{ {1}}）。

我不能让它在正确的地方转置然后循环。

我有类似的东西（我没有向这个宏添加循环）：

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。在 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

Answer 2

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