Try
Sub test()
Dim a, b, i As Long, ii As Long, iii As Long, n As Long, t As Long
a = Sheets("sheet1").Cells(1).CurrentRegion.Value
ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 6)
For i = 2 To UBound(a, 1)
For ii = 3 To UBound(a, 2) Step 4
If a(i, ii) = "" Then Exit For
n = n + 1: t = 3
For iii = 1 To 2: b(n, iii) = a(i, iii): Next
For iii = ii To ii + 3
b(n, t) = a(i, iii): t = t + 1
Next
Next ii, i
With Sheets("sheet2").Cells(1).Resize(, 6)
.CurrentRegion.ClearContents
.Value = a
With .Rows(2).Resize(n)
.Value = b
.Columns(1).NumberFormat = "d-mmm"
End With
End With
End Sub
Bookmarks