如何通过交叉方式复制数据？

Question

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

Answer 1

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

Answer 2

If you dispose of the newer dynamic features of MS 365 (esp. regarding the LET function), you might try the following formula alternative in cell E2 resulting in a spill range.

The formulat itself defines 1, 2 or 0-indices and assigns different table areas to these indices via CHOOSE .

=LET(data,A2:A103,rep,3,cols,4,idx,IF(data & "" <>"",MOD(ROW(data)-1,rep),rep),CHOOSE(idx,OFFSET(data,1,,,cols),OFFSET(data,-1,,,cols),""))

The LET function allows to assign names to partial caluculation results within the function's arguments, thus avoiding a nested function with redundant calculations.

For better readibility here including line breaks:

=LET(
    data,A2:A103,
    rep,3,
    cols,4,
    idx,IF(data & "" <>"",MOD(ROW(data)-1,rep),rep),
    CHOOSE(idx,OFFSET(data,1,,,cols),OFFSET(data,-1,,,cols),"")
    )

Side note : It might be interesting to experiment also with the partially not yet disponible functions ChooseCols and ChooseRows to slice & rearrange a given range by =CHOOSECOLS(CHOOSEROWS(A2:A3,{2,1}),{2,3,4}) applied extra upon each double row showing eg class, date & hr columns 2,3 & 4.