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

Question

Hi I am trying to cut the even rows and then paste it beside the odd rows.

My data looks like this

I have the following code which will only cut Row 2 and paste it beside Row 1

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

But I can't possible to it for every single row. So how do I make a loop such that it will do the rest of the work for me?

The ideal result should look something like this

Answer 1

This works for me:

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

Try the below:

Change the offset amounts and range in for loop depending on the data.

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