Hi Wadelair,

I upped all the numbers but had to code a bypass errors - see if it's what you wanted:

Sub Wadelair2(): Dim AccumD(81), AccumE(81) As Single, AccumT(81) As Single
Dim R As Long, D As Range, S As String, m As Integer, n As Integer: n = 1
Dim h As Long, i As Long, j As Long, k As Long
R = Cells.Find("This").Row: Set D = Range("D1:D" & R): h = 1
j = D.Find("Short").Row + 1: k = D.Find("Total").Row - 1
ProcessBlock:
If i > j Then Exit Sub
For i = j To k
If Cells(i, 1) = "WEEKDAY" Then
Weekdays:
For m = 6 To 25
On Error Resume Next
If Left(Cells(i, m), 1) = "$" Then _
S = Cells(i, m): Cells(i, m) = Right(S, Len(S) - 1)
AccumT(n) = AccumT(n) + Val(Cells(i, m))
AccumD(n) = AccumD(n) + Val(Cells(i, m)): n = n + 1
Next m
If n = 81 Then n = 1
If n = 21 Or n = 41 Or n = 61 Then
i = i + 1: GoTo Weekdays: End If: End If

If Cells(i, 1) = "WEEKEND" Then
Weekends:
For m = 6 To 25
If Left(Cells(i, m), 1) = "$" Then _
S = Cells(i, m): Cells(i, m) = Right(S, Len(S) - 1)
AccumT(n) = AccumT(n) + Val(Cells(i, m))
AccumE(n) = AccumE(n) + Val(Cells(i, m)): n = n + 1
Next m
If n = 81 Then n = 1
If n = 21 Or n = 41 Or n = 61 Then
i = i + 1: GoTo Weekends: End If
End If
Next i: n = 1

PostWDs:
For m = 6 To 25
Cells(i, m) = AccumD(n): n = n + 1
Next m
If n = 61 Then n = 1
If n = 21 Or n = 41 Then
i = i + 1: GoTo PostWDs: End If: i = i + 1
PostWEs:
For m = 6 To 25
Cells(i, m) = AccumE(n): n = n + 1
Next m
If n = 61 Then n = 1
If n = 21 Or n = 41 Then
i = i + 1: GoTo PostWEs: End If

        Erase AccumD: Erase AccumE
        
j = D.Find("Short", Range("D" & i)).Row + 1
k = D.Find("Total", Range("D" & j)).Row - 1
GoTo ProcessBlock

End Sub