Cleaning up data

as an option

Sub ert()
Dim x, y(), i&, j&, k&, n&, u&, id&, cnt&
Application.ScreenUpdating = False
x = Range("B3:R" & Cells(Rows.Count, 2).End(xlUp).Row + 1).Value
For i = 1 To UBound(x)
    ReDim y(1 To 1000): u = i
    y(1) = x(i, 1): y(2) = x(i, 2): y(3) = x(i, 3)

    Do Until Not IsNumeric(x(i + 1, 4))
        i = i + 1
    Loop
    n = i - u + 1
    For k = u To i
        For j = 4 To UBound(x, 2)
            If IsNumeric(x(k, j)) Then
                If Len(x(k, j)) Then id = x(k, j) + 4: y(id) = x(k + n, j)
            End If
        Next j
    Next k
    cnt = cnt + 1: Range("U3")(cnt, 1).Resize(, id).Value = y()
    i = i + n
Next i
Application.ScreenUpdating = True
End Sub