Global list_number As Integer
Sub NextList()

Dim n&, m&, s As Object
On Error Resume Next
For Each s In Sheets
  n = s.Name
  If n > m Then m = n
Next
Worksheets.Add(after:=Sheets(Sheets.Count)).Name = m + 1
list_number = m + 1
End Sub
Sub Prettify()
With Worksheets(CStr(list_number))
    .Range("C1:H1").Merge
    .Range("C1:H1") = "Trimester"
    .Range("J1:O1").Merge
    .Range("J1:O1") = "Trimester"
    .Range("C2") = "Date"
    .Range("J2") = "Date"
    .Range("D2") = "Day"
    .Range("K2") = "Day"
    .Range("E2") = "Lesson"
    .Range("L2") = "Lesson"
    .Range("F2") = "HW"
    .Range("M2") = "HW"
    .Range("G2") = "Grade"
    .Range("N2") = "Grade"
    .Range("H2") = "Sign"
    .Range("O2") = "Sign"
    .Range("D3:D5").Merge
    .Range("D6:D8").Merge
    .Range("D9:D11").Merge
    .Range("D3:D5") = "Monday"
    .Range("D6:D8") = "Tuesday"
    .Range("D9:D11") = "Wednesday"

    .Range("D3:D5").Orientation = xlUpward
    .Range("D6:D8").Orientation = xlUpward
    .Range("D9:D11").Orientation = xlUpward
    .Range("K3:K5").Merge
    .Range("K6:K8").Merge
    .Range("K9:K11").Merge
    .Range("K3:K5") = "Thursday"
    .Range("K6:K8") = "Friday"
    .Range("K9:K11") = "Saturday"

    .Range("K3:K5").Orientation = xlUpward
    .Range("K6:K8").Orientation = xlUpward
    .Range("K9:K11").Orientation = xlUpward
    .Range("E3") = "ICT"
    .Range("E4") = "Maths"
    .Range("E5") = "CS"
    .Range("L3") = "ICT"
    .Range("L4") = "Maths"
    .Range("L5") = "CS"
    .Range("E6") = "ICT"
    .Range("E7") = "Maths"
    .Range("E8") = "CS"
    .Range("L6") = "ICT"
    .Range("L7") = "Maths"
    .Range("L8") = "CS"
    .Range("L5") = "CS"
    .Range("E9") = "ICT"
    .Range("E10") = "Maths"
    .Range("E11") = "CS"
    .Range("L9") = "ICT"
    .Range("L10") = "Maths"
    .Range("L11") = "CS"



    .Range("J3:J5").Merge
    .Range("J6:J8").Merge
    .Range("J9:J11").Merge
    .Range("C3:C5").Merge
    .Range("C6:C8").Merge
    .Range("C9:C11").Merge
    .Range("J3:J5").Orientation = xlUpward
    .Range("J6:J8").Orientation = xlUpward
    .Range("J9:J11").Orientation = xlUpward

    .Range("C3:C5").Orientation = xlUpward
    .Range("C6:C8").Orientation = xlUpward
    .Range("C9:C11").Orientation = xlUpward
End With
End Sub

Sub set_date(Dat As Integer, Day As String, month As String)
Dim to_be_pasted As String

to_be_pasted = CStr(Dat) & "  " & month
If Day = "Monday" Then
Worksheets(CStr(list_number)).Range("C3:C5") = to_be_pasted
Worksheets(CStr(list_number)).Range("I1") = get_trem(Dat)
End If
If Day = "Tuesday" Then
Worksheets(CStr(list_number)).Range("C6:C8") = to_be_pasted
Worksheets(CStr(list_number)).Range("I1") = get_trem(Dat)
End If
If Day = "Wednesday" Then
Worksheets(CStr(list_number)).Range("C9:C11") = to_be_pasted
Worksheets(CStr(list_number)).Range("I1") = get_trem(Dat)
End If
If Day = "Thursday" Then
Worksheets(CStr(list_number)).Range("J3:J5") = to_be_pasted
Worksheets(CStr(list_number)).Range("P1") = get_trem(Dat)
End If
If Day = "Friday" Then
Worksheets(CStr(list_number)).Range("J6:J8") = to_be_pasted
Worksheets(CStr(list_number)).Range("P1") = get_trem(Dat)
End If
If Day = "Saturday" Then
Worksheets(CStr(list_number)).Range("J9:J11") = to_be_pasted
Worksheets(CStr(list_number)).Range("P1") = get_trem(Dat)
End If

End Sub






Function get_month(Day As Integer) As String
If Day <= 30 Then
get_month = "Sep"
ElseIf Day <= 61 Then
get_month = "Oct"
ElseIf Day <= 92 Then
get_month = "Nov"
ElseIf Day <= 123 Then
get_month = "Dec"
ElseIf Day <= 154 Then
get_month = "Jan"
ElseIf Day <= 183 Then
get_month = "Feb"
ElseIf Day <= 214 Then
get_month = "Mar"
ElseIf Day <= 244 Then
get_month = "Apr"
ElseIf Day > 244 Then
get_month = "May"
End If
End Function
Function get_trem(Day As Integer) As String

If get_month(Day) = "Sep" Or get_month(Day) = "Oct" Or get_month(Day) = "Nov" Then get_trem = "I"
If get_month(Day) = "Dec" Or get_month(Day) = "Jan" Or get_month(Day) = "Feb" Then get_trem = "II"
If get_month(Day) = "Mar" Or get_month(Day) = "Apr" Or get_month(Day) = "May" Then get_trem = "III"


End Function

Sub G()
list_number = 1
Dim WeekDays() As Variant
Dim months(9)
Dim Day As Integer
Dim trim As Integer
Dim month As Integer
Dim counter As Integer
Dim wd_val As String

Dim days(275) As Integer
Day = 0
WeekDays = Array("Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday")
months(0) = 30
months(1) = 31
months(2) = 31
months(3) = 31
months(4) = 31
months(5) = 29
months(6) = 31
months(7) = 30
months(8) = 31
counter = 0
For month = 0 To 8
    For Day = 1 To months(month)
     days(counter) = Day
     counter = counter + 1
     Next Day
Next month

'Call NextList
Dim i As Integer
Dim str As String
For i = 1 To 35

  Call Prettify
   If (i - 1) Mod 7 = 0 Then NextList
    str = WeekDays((i - 1) Mod 7)
   Call set_date(days(i), str, get_month(i))
Next i



End Sub