削除を繰り返す？

知恵袋で回答したもので、奇数行６列・偶数行２列からなるデータが何千行とあるシートを、奇数行のデータを偶数行の右に転記し、奇数行を削除するにはどうしたらいいかって質問でした。

そんなに削除したくないよね？

遅くなるし・・・

なので、書き換える方法を回答。

Sub OneCase()
    Dim i As Long, j As Long, lastRow As Long
    Dim dataArray() As Variant
    
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    ReDim dataArray(1 To lastRow \ 2, 1 To 10)
    
    For i = 2 To lastRow Step 2
        For j = 1 To 2
            dataArray(i \ 2, j) = Cells(i, j).Value
        Next j
        
        For j = 3 To UBound(dataArray, 2)
            dataArray(i \ 2, j) = Cells(i - 1, j - 2).Value
        Next j
    Next i
    
    Cells.Clear
    
    Range("G1:H" & UBound(dataArray)).NumberFormatLocal = "0.00%"
    
    Range("A1").Resize(UBound(dataArray), UBound(dataArray, 2)) = dataArray
End Sub