Adding code to test copy facility:
Sub explode_results()
Dim dStrt As Range, dEnd As Range, cnt As Long, MyCell As Range, i As Long, ci As Long, nCnt As Long
Dim aCnt As Long, Arri As Long, Arr, c As Long, iCol As Long
Dim sh As Worksheet
For Each sh In Sheets(Array("Shift 1 " & Format(Date, "yyyy"), "Shift 2 " & Format(Date, "yyyy"), "Shift 3 " & Format(Date, "yyyy"), _
"Shift 4 " & Format(Date, "yyyy"), "Shift 5 " & Format(Date, "yyyy")))
Set dStrt = sh.Cells.Find(What:=CDate(Sheets("Summary").Range("A3").Value), After:=sh.Range("A1"), LookIn:=xlFormulas, _
        LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext)
Set dEnd = sh.Cells.Find(What:=CDate(Sheets("Summary").Range("A5").Value), After:=sh.Range("A1"), LookIn:=xlFormulas, _
        LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext)
        
cnt = Range(dStrt.Address & ":" & dEnd.Address).Cells.Count

ci = 0
nCnt = 0
aCnt = 0
iCol = 0

Arr = Array("cnproc", "bisproc", "rcproc", "fdflav", "mpdpk", "crnpk", "ctcnpk", "bscpk", "blkhi", "tkflr", _
"spprt", "bgsply", "temps", "flxday", "whouse", "craft")

For Arri = 0 To 15
For iCol = 0 To sh.Range(Arr(Arri)).Columns.Count
For i = 0 To cnt
    If Cells(dStrt.Row + i, sh.Range(Arr(Arri)).Column + iCol).Value <> "" Then
        ci = ci + 1
    End If
nCnt = nCnt + 1
    If nCnt > 6 And ci > 1 Then
        ci = 0
        aCnt = aCnt + 1
    End If
    If nCnt > 6 Then
        nCnt = 0
    End If
    iCol = iCol + 1
    If i = Arri + iCol + 2 Then GoTo Nxt
Next i
Nxt:
Next iCol
Next Arri
Next sh
MsgBox "ci = " & ci & vbLf & "nCnt = " & nCnt & vbLf & "aCnt = " & aCnt & vbLf & Arri
End Sub

Google Me
Find me located here Simon Lloyd and what i'm about Here
The above is NOT a link to a forum so is NOT against Rule 13