Vba To Calculate Across Monthly Worksheet

My problem is that I need Week Totals to calculate the day dated sheets before them and the Monthly total to calculate the Week Totals. Every month the workbook will be different due to amount of days and dates in each month. I was hoping if someone could help me out with code to make this work.

The ranges are B6:E24, G6:H24, K624 (top team)
The ranges are B28:E49, G28:H49, K2849 (bottom team)
I'm not sure why the smile faces are appearing but it should be P in both cases

The ranges can also change if agents are added or leave

The code I use to build the Monthly sheet, copy the master and zoom

Sub
Dim Dte As Date, Dy As Date
Dim i As Long, j As Long, Dys As Long
Dim CountWeek As Boolean
Dim Shts As Long

Application.ScreenUpdating = False
'Get 1st of month
Dte = DateValue("1/" & Month(Date) & "/" & Year(Date))
'Count days in month
Dys = DateAdd("m", 1, Dte) - Dte
'Add requisite sheets
Shts = Sheets.Count
Sheets.Add after:=Sheets(Shts), Count:=(Dys + 1)
' Loop through sheets
For i = Shts + 1 To Sheets.Count - 1
'Get date
Dy = DateValue(i - Shts & "/" & Month(Date) & "/" & Year(Date))
Select Case Weekday(Dy)
'If weekday
Case 2, 3, 4, 5, 6, 7
If ((Dy - Dte - Dys) = -1) Then
j = j + 1
Sheets(i).Name = "WEEK " & j
Else
Sheets(i).Name = Format(Dy, "ddd dd-mm-yy")
CountWeek = True
End If
Case Else
'If Sunday
j = j + 1
If CountWeek = True Then
Sheets(i).Name = "WEEK " & j
End If
End Select
Next
'Add total
Sheets(Sheets.Count).Name = UCase(Format(Dy, "MMM")) & " MONTH END TOTAL"
Dim ws As Worksheet
Dim lindex As Long, lLoop As Long

With Sheets("miss5 MS")
lindex = .Index
.Range("A1:AA1000").Copy
End With

For lLoop = lindex To Sheets.Count
Sheets(lLoop).Cells(1, 1).PasteSpecial
Next lLoop

For Each ws In ActiveWorkbook.Worksheets
ws.Activate
ActiveWindow.Zoom = 75
Next ws

Application.CutCopyMode = False
End Sub

Hope I have been clear.

Thank you for your time

Naz75

[2718 byte] By [Naz75] at [2008-1-10]