这似乎行得通：

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

如果您放弃了 MS 365 的较新动态功能（尤其是关于LET函数），您可以在单元格E2中尝试以下公式替代，从而产生溢出范围。
该公式本身定义了1、2或0索引，并通过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),""))

LET函数允许在函数的参数中为部分计算结果赋值，从而避免嵌套函数具有冗余计算。
为了更好地理解此处的内容，请使用换行符：

=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),"")
    )

• 附注 *：还可以尝试使用部分尚未处理的函数ChooseCols和ChooseRows，通过额外应用于每个双行的=CHOOSECOLS(CHOOSEROWS(A2:A3,{2,1}),{2,3,4})对给定范围进行切片和重新排列，例如显示class、date和hr列2、3和4。