Adjust Macros Formula Help

[IdabaMalouki]

I have an irregular data set that looks like this:

Sub organized_data_v1()
  Dim i As Long, k As Long
  
  Application.ScreenUpdating = False
  k = 2
  For i = 1 To Range("A" & Rows.Count).End(3).Row Step 20
    Range("C" & k).Value = Range("A" & i + 17)
    Range("D" & k).Resize(1, 6).Value = Application.Transpose(Range("A" & i + 3).Resize(6).Value)
    Range("D" & k + 1).Resize(1, 6).Value = Application.Transpose(Range("A" & i + 9).Resize(6).Value)
    k = k + 2
  Next
  Application.ScreenUpdating = True
End Sub

Can the above VBA code be tweaked to sort the above irregular dataset from colum A into columns C thru J as pictured above? Thanks in advance.

 

[Sam_D_Ben]

Something like this,

Sub x()
    Dim w As Worksheet, i&, o&, r&, d
    Set w = ActiveSheet
    r = w.Cells(w.Rows.Count, 1).End(3).Row: o = 2

    For i = 1 To r
        If InStr(1, LCase(w.Cells(i, 1)), "spread") > 0 Then
            On Error Resume Next
            d = Array( _
                w.Cells(i + 23, 1).Value, w.Cells(i + 3, 1).Value, w.Cells(i + 5, 1).Value, _
                w.Cells(i + 7, 1).Value, w.Cells(i + 8, 1).Value, w.Cells(i + 9, 1).Value, _
                w.Cells(i + 10, 1).Value, w.Cells(i + 11, 1).Value, w.Cells(i + 12, 1).Value, _
                w.Cells(i + 14, 1).Value, w.Cells(i + 16, 1).Value, w.Cells(i + 17, 1).Value, _
                w.Cells(i + 18, 1).Value, w.Cells(i + 19, 1).Value, w.Cells(i + 20, 1).Value)

            w.Range(w.Cells(o, 3), w.Cells(o, 10)).Value = _
                Application.Transpose(Application.Index(d, Evaluate("ROW(1:8)")))

            w.Range(w.Cells(o + 1, 4), w.Cells(o + 1, 10)).Value = _
                Application.Transpose(Application.Index(d, Evaluate("ROW(9:15)")))

            w.Cells(o, 3).NumberFormat = "h:mm AM/PM"
            o = o + 2: On Error GoTo 0
        End If
    Next
End Sub

 

[IdabaMalouki]

Something like this,

Sub x()
    Dim w As Worksheet, i&, o&, r&, d
    Set w = ActiveSheet
    r = w.Cells(w.Rows.Count, 1).End(3).Row: o = 2

    For i = 1 To r
        If InStr(1, LCase(w.Cells(i, 1)), "spread") > 0 Then
            On Error Resume Next
            d = Array( _
                w.Cells(i + 23, 1).Value, w.Cells(i + 3, 1).Value, w.Cells(i + 5, 1).Value, _
                w.Cells(i + 7, 1).Value, w.Cells(i + 8, 1).Value, w.Cells(i + 9, 1).Value, _
                w.Cells(i + 10, 1).Value, w.Cells(i + 11, 1).Value, w.Cells(i + 12, 1).Value, _
                w.Cells(i + 14, 1).Value, w.Cells(i + 16, 1).Value, w.Cells(i + 17, 1).Value, _
                w.Cells(i + 18, 1).Value, w.Cells(i + 19, 1).Value, w.Cells(i + 20, 1).Value)

            w.Range(w.Cells(o, 3), w.Cells(o, 10)).Value = _
                Application.Transpose(Application.Index(d, Evaluate("ROW(1:8)")))

            w.Range(w.Cells(o + 1, 4), w.Cells(o + 1, 10)).Value = _
                Application.Transpose(Application.Index(d, Evaluate("ROW(9:15)")))

            w.Cells(o, 3).NumberFormat = "h:mm AM/PM"
            o = o + 2: On Error GoTo 0
        End If
    Next
End Sub

Thank you, Maestro!!!