How to copy data by crossing way?-CodePudding

I need to copy values on a crossing way , as on the below pictures:
I arranged my data as two rows (with values) and then a one blank row and so on.
I tried the below code , but the output result is incorrect.
In advance, thanks for your help.

Sub Copy_by_crossing()
 
  Dim ws As Worksheet, lastRow As Long, i As Long
 
  Set ws = ThisWorkbook.ActiveSheet
  lastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
 
  For i = 2 To lastRow
 
    If ws.Range("E" & i   1).Value = "" Then
       ws.Range("E" & i   1).Resize(, 4).Value = ws.Range("A" & i, "D" & i).Value
    End If
 
   Next i
 
End Sub

CodePudding user response：

This seems to work:

Option Explicit
Sub Copy_By_Crossing()
    Dim WS As Worksheet, rSrc As Range, rRes As Range
    Dim vSrc, vRes
    Dim I As Long, J As Long
    

'work in VBA arrays for faster execution times
    
Set WS = ThisWorkbook.Worksheets("Sheet1")
With WS
    Set rSrc = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=4)
    vSrc = rSrc
    Set rRes = rSrc.Offset(0, UBound(vSrc, 2))
    ReDim vRes(1 To UBound(vSrc, 1), 1 To UBound(vSrc, 2))
End With

'create results array
'headers
For J = 1 To UBound(vSrc, 2)
    vRes(1, J) = vSrc(1, J)
Next J

'Reverse each pair of data
For I = 2 To UBound(vSrc, 1) Step 3
    For J = 1 To UBound(vSrc, 2)
        vRes(I   1, J) = vSrc(I, J)
        vRes(I, J) = vSrc(I   1, J)
    Next J
Next I
        
'Write back to the worksheet
With rRes
    .EntireColumn.Clear
    .Value = vRes
    .Style = "Output" 'This line may not work with non-english versions
    .EntireColumn.AutoFit
End With

End Sub