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