Maybe :
Sub Test()
Dim rng As Range, a As Range, arrHeader, arrIn, arrOut, currentHeader1 As String, currentHeader2 As String
Dim lastCol As Long, iStart As Long, i As Long, j As Long, p As Long
With Sheets("daily")
lastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
arrHeader = Range(.Range("A2"), .Cells(3, lastCol))
Set rng = Intersect(.UsedRange, .Columns("A")).SpecialCells(xlCellTypeConstants)
End With
With Sheets("sample output")
.UsedRange.Offset(1).ClearContents
For Each a In rng.Areas
arrIn = a.Resize(, lastCol).Value
ReDim arrOut(1 To UBound(arrIn, 1) * UBound(arrIn, 2), 1 To 6)
p = 0
If arrIn(1, 4) = "" Then
currentHeader1 = arrIn(1, 1)
currentHeader2 = arrIn(2, 1)
iStart = 3
Else
currentHeader2 = arrIn(1, 1)
iStart = 2
End If
For i = iStart To UBound(arrIn, 1)
For j = 5 To UBound(arrIn, 2)
If arrIn(i, j) = "" Then
j = j + 1
Else
p = p + 1
arrOut(p, 1) = currentHeader1
arrOut(p, 2) = currentHeader2
arrOut(p, 3) = arrIn(i, 1)
arrOut(p, 4) = arrHeader(1, j)
arrOut(p, 5) = arrHeader(2, j)
arrOut(p, 6) = arrIn(i, j)
End If
Next j
Next i
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(p, 6).Value = arrOut
Next a
End With
End Sub
Bookmarks