VBA中的循环剪切和粘贴功能

Question

嗨，我正在尝试剪切偶数行，然后将其粘贴到奇数行旁边。

我的数据看起来像这样

我有以下代码，它只会剪切第 2 行并将其粘贴到第 1 行旁边

Range("B2:E2").Cut Range("F2")

但我不可能对每一行都这样做。 那么我如何制作一个循环，以便它为我完成其余的工作？

理想的结果应该是这样的

Answer 1

这对我有用：

Sub SubCutAndPaste()

    'Declaring variable.
    Dim RngRange01 As Range
    
    'Setting variable.
    Set RngRange01 = ActiveSheet.Range("A1:E1")
    
    'Starting a Do-Loop cycle that will end when all the cells in the given RngRange01 are _
    blank.
    Do Until Excel.WorksheetFunction.CountBlank(RngRange01) = RngRange01.Cells.Count
        
        'Cutting-pasting the second lane. The second lane has the same columns as the _
        RngRange01 and it is offset by 1 column.
        RngRange01.Offset(1, 1).Cut RngRange01.Offset(0, RngRange01.Columns.Count)
        
        'Setting RngRange01 for the next lane.
        Set RngRange01 = RngRange01.Offset(2, 0)
    Loop
    
End Sub

Answer 2

试试下面的：

根据数据更改 for 循环中的偏移量和范围。

Sub ReFormat()

    Dim cell
    Dim CopyRange As String
    Dim PasteRange As String
    
    For Each cell In Range("A1:A12")
    
        ' Filter out only odd rows
        If (cell.Row Mod 2) <> 0 Then
        
            'create range string for values to copy
            CopyRange = (cell.Offset(1, 1).Address + ":" + cell.Offset(1, 5).Address)
            
            'create range string for values to paste into
            PasteRange = (cell.Offset(0, 5).Address + ":" + cell.Offset(0, 9).Address)
            
            Range(CopyRange).Copy
            
            Range(PasteRange).PasteSpecial xlPasteValues
            
            Range(CopyRange).ClearContents
            
        End If
    
    Next
    
End Sub