How to make calendars in excel?

[airborne spoon]

Ok i hope this goes into the "code" thing right because its long AF lol

Anyway i am trying to make a work calendar for a business to show the open and closed dates, once i have a calendar i just easily change days to green or red accordingly. But making the actual calendar takes longer than I'd prefer to waste time on by typing out the first 10-15 days then dragging the box to have excel auto fill the rest of the days. I found this code on the Microsoft site for making a macro for a calendar and it works sorta... I've managed to change the font size and make it unprotected and even change the size of the cells but i cant figure out how to do the last couple things to make it perfect for my use case.

This code makes the day a separate cell and thus makes it bigger than i need. I want the day to be the whole box, as you can see in the pic below of the ones I've typed out. Also it makes the lines with the super thick lines i want it to be the standard line around everything.

Once i make a calendar i can copy it to another sheet to make up my quarterly open close calendar unless there is a way to make this code do multiple months at once but so far i can only get it to make one at a time.

 

Also i have no idea WTF 90% of this means and i don't know very much about this type of thing (code in general) but i know excel is powerful and can simplify a lot of stuff so that's what I'm trying to do.

 

Sub CalendarMaker()

       ' Unprotect sheet if had previous calendar to prevent error.
       ActiveSheet.Protect DrawingObjects:=False, Contents:=False, _
          Scenarios:=False
       ' Prevent screen flashing while drawing calendar.
       Application.ScreenUpdating = False
       ' Set up error trapping.
       On Error GoTo MyErrorTrap
       ' Clear area a1:g14 including any previous calendar.
       Range("a1:g14").Clear
       ' Use InputBox to get desired month and year and set variable
       ' MyInput.
       MyInput = InputBox("Type in Month and year for Calendar ")
       ' Allow user to end macro with Cancel in InputBox.
       If MyInput = "" Then Exit Sub
       ' Get the date value of the beginning of inputted month.
       StartDay = DateValue(MyInput)
       ' Check if valid date but not the first of the month
       ' -- if so, reset StartDay to first day of month.
       If Day(StartDay) <> 1 Then
           StartDay = DateValue(Month(StartDay) & "/1/" & _
               Year(StartDay))
       End If
       ' Prepare cell for Month and Year as fully spelled out.
       Range("a1").NumberFormat = "mmmm yyyy"
       ' Center the Month and Year label across a1:g1 with appropriate
       ' size, height and bolding.
       With Range("a1:g1")
           .HorizontalAlignment = xlCenterAcrossSelection
           .VerticalAlignment = xlCenter
           .Font.Size = 12
           .Font.Bold = False
           .RowHeight = 35
       End With
       ' Prepare a2:g2 for day of week labels with centering, size,
       ' height and bolding.
       With Range("a2:g2")
           .ColumnWidth = 2
           .VerticalAlignment = xlCenter
           .HorizontalAlignment = xlCenter
           .VerticalAlignment = xlCenter
           .Orientation = xlHorizontal
           .Font.Size = 12
           .Font.Bold = False
           .RowHeight = 20
       End With
       ' Put days of week in a2:g2.
       Range("a2") = "S"
       Range("b2") = "M"
       Range("c2") = "T"
       Range("d2") = "W"
       Range("e2") = "T"
       Range("f2") = "F"
       Range("g2") = "S"
       ' Prepare a3:g7 for dates with left/top alignment, size, height
       ' and bolding.
       With Range("a3:g8")
           .HorizontalAlignment = xlRight
           .VerticalAlignment = xlTop
           .Font.Size = 12
           .Font.Bold = False
           .RowHeight = 21
       End With
       ' Put inputted month and year fully spelling out into "a1".
       Range("a1").Value = Application.Text(MyInput, "mmmm yyyy")
       ' Set variable and get which day of the week the month starts.
       DayofWeek = Weekday(StartDay)
       ' Set variables to identify the year and month as separate
       ' variables.
       CurYear = Year(StartDay)
       CurMonth = Month(StartDay)
       ' Set variable and calculate the first day of the next month.
       FinalDay = DateSerial(CurYear, CurMonth + 1, 1)
       ' Place a "1" in cell position of the first day of the chosen
       ' month based on DayofWeek.
       Select Case DayofWeek
           Case 1
               Range("a3").Value = 1
           Case 2
               Range("b3").Value = 1
           Case 3
               Range("c3").Value = 1
           Case 4
               Range("d3").Value = 1
           Case 5
               Range("e3").Value = 1
           Case 6
               Range("f3").Value = 1
           Case 7
               Range("g3").Value = 1
       End Select
       ' Loop through range a3:g8 incrementing each cell after the "1"
       ' cell.
       For Each cell In Range("a3:g8")
           RowCell = cell.Row
           ColCell = cell.Column
           ' Do if "1" is in first column.
           If cell.Column = 1 And cell.Row = 3 Then
           ' Do if current cell is not in 1st column.
           ElseIf cell.Column <> 1 Then
               If cell.Offset(0, -1).Value >= 1 Then
                   cell.Value = cell.Offset(0, -1).Value + 1
                   ' Stop when the last day of the month has been
                   ' entered.
                   If cell.Value > (FinalDay - StartDay) Then
                       cell.Value = ""
                       ' Exit loop when calendar has correct number of
                       ' days shown.
                       Exit For
                   End If
               End If
           ' Do only if current cell is not in Row 3 and is in Column 1.
           ElseIf cell.Row > 3 And cell.Column = 1 Then
               cell.Value = cell.Offset(-1, 6).Value + 1
               ' Stop when the last day of the month has been entered.
               If cell.Value > (FinalDay - StartDay) Then
                   cell.Value = ""
                   ' Exit loop when calendar has correct number of days
                   ' shown.
                   Exit For
               End If
           End If
       Next

       ' Create Entry cells, format them centered, wrap text, and border
       ' around days.
       For x = 0 To 5
           Range("A4").Offset(x * 2, 0).EntireRow.Insert
           With Range("A4:G4").Offset(x * 2, 0)
               .RowHeight = 20
               .HorizontalAlignment = xlCenter
               .VerticalAlignment = xlTop
               .WrapText = True
               .Font.Size = 12
               .Font.Bold = False
               ' Unlock these cells to be able to enter text later after
               ' sheet is protected.
               .Locked = False
           End With
           ' Put border around the block of dates.
           With Range("A3").Offset(x * 2, 0).Resize(2, _
           7).Borders(xlLeft)
               .Weight = xlThick
               .ColorIndex = xlAutomatic
           End With

           With Range("A3").Offset(x * 2, 0).Resize(2, _
           7).Borders(xlRight)
               .Weight = xlThick
               .ColorIndex = xlAutomatic
           End With
           Range("A3").Offset(x * 2, 0).Resize(2, 7).BorderAround _
              Weight:=xlThick, ColorIndex:=xlAutomatic
       Next
       If Range("A13").Value = "" Then Range("A13").Offset(0, 0) _
          .Resize(2, 8).EntireRow.Delete
       ' Turn off gridlines.
       ActiveWindow.DisplayGridlines = False
       ' Protect sheet to prevent overwriting the dates.
       ActiveSheet.Protect DrawingObjects:=False, Contents:=False, _
          Scenarios:=False

       ' Resize window to show all of calendar (may have to be adjusted
       ' for video configuration).
       ActiveWindow.WindowState = xlMaximized
       ActiveWindow.ScrollRow = 1

       ' Allow screen to redraw with calendar showing.
       Application.ScreenUpdating = True
       ' Prevent going to error trap unless error found by exiting Sub
       ' here.
       Exit Sub
   ' Error causes msgbox to indicate the problem, provides new input box,
   ' and resumes at the line that caused the error.
MyErrorTrap:
       MsgBox "You may not have entered your Month and Year correctly." _
           & Chr(13) & "Spell the Month correctly" _
           & " (or use 3 letter abbreviation)" _
           & Chr(13) & "and 4 digits for the Year"
       MyInput = InputBox("Type in Month and year for Calendar")
       If MyInput = "" Then Exit Sub
       Resume
   End Sub

 

 

[manikyath]

for a risk of going way off topic... why not 'just' have a calendar in outlook? office sort of has this thing where every application was made with a specific purpose, and having one of them do the function of another is often painful...

 

on that note, give me a poke in the morning if you really need this in excel, and i could probably build something in VBA for you. (it's midnight here now, and if i try going at it now i'll just spend until 7AM making mistakes)

 

also, microsoft is still very much set on killing VBA, if you are on M365 apps or office 2019 you shouldnt rely on a VBA implementation because it will be going away.

[airborne spoon]

5 minutes ago, manikyath said:

for a risk of going way off topic... why not 'just' have a calendar in outlook? office sort of has this thing where every application was made with a specific purpose, and having one of them do the function of another is often painful...

 

on that note, give me a poke in the morning if you really need this in excel, and i could probably build something in VBA for you. (it's midnight here now, and if i try going at it now i'll just spend until 7AM making mistakes)

 

also, microsoft is still very much set on killing VBA, if you are on M365 apps or office 2019 you shouldnt rely on a VBA implementation because it will be going away.

this is to print out and post around on the doors of the building so customers know when we will be closed. outlook will not work for obvious reasons lol

I'm doing this at work computer so its office 365 i think. I will be leaving in like 7 months and i want to have a system in place for the next person to be able to just keep on doing things.

Like i said i got the code down pretty close to what I'm looking for but its just those last 2 things i don't know how to change them.

[PDifolco]

1 hour ago, airborne spoon said:

Ok i hope this goes into the "code" thing right because its long AF lol

Anyway i am trying to make a work calendar for a business to show the open and closed dates, once i have a calendar i just easily change days to green or red accordingly. But making the actual calendar takes longer than I'd prefer to waste time on by typing out the first 10-15 days then dragging the box to have excel auto fill the rest of the days. I found this code on the Microsoft site for making a macro for a calendar and it works sorta... I've managed to change the font size and make it unprotected and even change the size of the cells but i cant figure out how to do the last couple things to make it perfect for my use case.

This code makes the day a separate cell and thus makes it bigger than i need. I want the day to be the whole box, as you can see in the pic below of the ones I've typed out. Also it makes the lines with the super thick lines i want it to be the standard line around everything.

Once i make a calendar i can copy it to another sheet to make up my quarterly open close calendar unless there is a way to make this code do multiple months at once but so far i can only get it to make one at a time.

 

Also i have no idea WTF 90% of this means and i don't know very much about this type of thing (code in general) but i know excel is powerful and can simplify a lot of stuff so that's what I'm trying to do.

 

Sub CalendarMaker()

       ' Unprotect sheet if had previous calendar to prevent error.
       ActiveSheet.Protect DrawingObjects:=False, Contents:=False, _
          Scenarios:=False
       ' Prevent screen flashing while drawing calendar.
       Application.ScreenUpdating = False
       ' Set up error trapping.
       On Error GoTo MyErrorTrap
       ' Clear area a1:g14 including any previous calendar.
       Range("a1:g14").Clear
       ' Use InputBox to get desired month and year and set variable
       ' MyInput.
       MyInput = InputBox("Type in Month and year for Calendar ")
       ' Allow user to end macro with Cancel in InputBox.
       If MyInput = "" Then Exit Sub
       ' Get the date value of the beginning of inputted month.
       StartDay = DateValue(MyInput)
       ' Check if valid date but not the first of the month
       ' -- if so, reset StartDay to first day of month.
       If Day(StartDay) <> 1 Then
           StartDay = DateValue(Month(StartDay) & "/1/" & _
               Year(StartDay))
       End If
       ' Prepare cell for Month and Year as fully spelled out.
       Range("a1").NumberFormat = "mmmm yyyy"
       ' Center the Month and Year label across a1:g1 with appropriate
       ' size, height and bolding.
       With Range("a1:g1")
           .HorizontalAlignment = xlCenterAcrossSelection
           .VerticalAlignment = xlCenter
           .Font.Size = 12
           .Font.Bold = False
           .RowHeight = 35
       End With
       ' Prepare a2:g2 for day of week labels with centering, size,
       ' height and bolding.
       With Range("a2:g2")
           .ColumnWidth = 2
           .VerticalAlignment = xlCenter
           .HorizontalAlignment = xlCenter
           .VerticalAlignment = xlCenter
           .Orientation = xlHorizontal
           .Font.Size = 12
           .Font.Bold = False
           .RowHeight = 20
       End With
       ' Put days of week in a2:g2.
       Range("a2") = "S"
       Range("b2") = "M"
       Range("c2") = "T"
       Range("d2") = "W"
       Range("e2") = "T"
       Range("f2") = "F"
       Range("g2") = "S"
       ' Prepare a3:g7 for dates with left/top alignment, size, height
       ' and bolding.
       With Range("a3:g8")
           .HorizontalAlignment = xlRight
           .VerticalAlignment = xlTop
           .Font.Size = 12
           .Font.Bold = False
           .RowHeight = 21
       End With
       ' Put inputted month and year fully spelling out into "a1".
       Range("a1").Value = Application.Text(MyInput, "mmmm yyyy")
       ' Set variable and get which day of the week the month starts.
       DayofWeek = Weekday(StartDay)
       ' Set variables to identify the year and month as separate
       ' variables.
       CurYear = Year(StartDay)
       CurMonth = Month(StartDay)
       ' Set variable and calculate the first day of the next month.
       FinalDay = DateSerial(CurYear, CurMonth + 1, 1)
       ' Place a "1" in cell position of the first day of the chosen
       ' month based on DayofWeek.
       Select Case DayofWeek
           Case 1
               Range("a3").Value = 1
           Case 2
               Range("b3").Value = 1
           Case 3
               Range("c3").Value = 1
           Case 4
               Range("d3").Value = 1
           Case 5
               Range("e3").Value = 1
           Case 6
               Range("f3").Value = 1
           Case 7
               Range("g3").Value = 1
       End Select
       ' Loop through range a3:g8 incrementing each cell after the "1"
       ' cell.
       For Each cell In Range("a3:g8")
           RowCell = cell.Row
           ColCell = cell.Column
           ' Do if "1" is in first column.
           If cell.Column = 1 And cell.Row = 3 Then
           ' Do if current cell is not in 1st column.
           ElseIf cell.Column <> 1 Then
               If cell.Offset(0, -1).Value >= 1 Then
                   cell.Value = cell.Offset(0, -1).Value + 1
                   ' Stop when the last day of the month has been
                   ' entered.
                   If cell.Value > (FinalDay - StartDay) Then
                       cell.Value = ""
                       ' Exit loop when calendar has correct number of
                       ' days shown.
                       Exit For
                   End If
               End If
           ' Do only if current cell is not in Row 3 and is in Column 1.
           ElseIf cell.Row > 3 And cell.Column = 1 Then
               cell.Value = cell.Offset(-1, 6).Value + 1
               ' Stop when the last day of the month has been entered.
               If cell.Value > (FinalDay - StartDay) Then
                   cell.Value = ""
                   ' Exit loop when calendar has correct number of days
                   ' shown.
                   Exit For
               End If
           End If
       Next

       ' Create Entry cells, format them centered, wrap text, and border
       ' around days.
       For x = 0 To 5
           Range("A4").Offset(x * 2, 0).EntireRow.Insert
           With Range("A4:G4").Offset(x * 2, 0)
               .RowHeight = 20
               .HorizontalAlignment = xlCenter
               .VerticalAlignment = xlTop
               .WrapText = True
               .Font.Size = 12
               .Font.Bold = False
               ' Unlock these cells to be able to enter text later after
               ' sheet is protected.
               .Locked = False
           End With
           ' Put border around the block of dates.
           With Range("A3").Offset(x * 2, 0).Resize(2, _
           7).Borders(xlLeft)
               .Weight = xlThick
               .ColorIndex = xlAutomatic
           End With

           With Range("A3").Offset(x * 2, 0).Resize(2, _
           7).Borders(xlRight)
               .Weight = xlThick
               .ColorIndex = xlAutomatic
           End With
           Range("A3").Offset(x * 2, 0).Resize(2, 7).BorderAround _
              Weight:=xlThick, ColorIndex:=xlAutomatic
       Next
       If Range("A13").Value = "" Then Range("A13").Offset(0, 0) _
          .Resize(2, 8).EntireRow.Delete
       ' Turn off gridlines.
       ActiveWindow.DisplayGridlines = False
       ' Protect sheet to prevent overwriting the dates.
       ActiveSheet.Protect DrawingObjects:=False, Contents:=False, _
          Scenarios:=False

       ' Resize window to show all of calendar (may have to be adjusted
       ' for video configuration).
       ActiveWindow.WindowState = xlMaximized
       ActiveWindow.ScrollRow = 1

       ' Allow screen to redraw with calendar showing.
       Application.ScreenUpdating = True
       ' Prevent going to error trap unless error found by exiting Sub
       ' here.
       Exit Sub
   ' Error causes msgbox to indicate the problem, provides new input box,
   ' and resumes at the line that caused the error.
MyErrorTrap:
       MsgBox "You may not have entered your Month and Year correctly." _
           & Chr(13) & "Spell the Month correctly" _
           & " (or use 3 letter abbreviation)" _
           & Chr(13) & "and 4 digits for the Year"
       MyInput = InputBox("Type in Month and year for Calendar")
       If MyInput = "" Then Exit Sub
       Resume
   End Sub

 

 

Well that's the VB macro way to make one, but you can make one just with formulas, I did that for one task at work (managing maturity/roll dates on a FXSwap book haha) quite quickly

[airborne spoon]

3 hours ago, PDifolco said:

Well that's the VB macro way to make one, but you can make one just with formulas, I did that for one task at work (managing maturity/roll dates on a FXSwap book haha) quite quickly

How? I'm all about finding easier ways to make things. Can you show me what formulas, how you did it?

[wanderingfool2]

Especially if you are planning to just copy and paste each time, I agree with what @PDifolco says, it's probably easier to do it with formulas...so you generate the entire year based on the formula.

 

2 hours ago, airborne spoon said:

How? I'm all about finding easier ways to make things. Can you show me what formulas, how you did it?

I don't have Excel on my current computer, but if I remember and am bored I'll quickly write up a few formulas and post them here

[kirashi]

7 hours ago, airborne spoon said:

this is to print out and post around on the doors of the building so customers know when we will be closed. outlook will not work for obvious reasons lol

I'm doing this at work computer so its office 365 i think. I will be leaving in like 7 months and i want to have a system in place for the next person to be able to just keep on doing things.

Like i said i got the code down pretty close to what I'm looking for but its just those last 2 things i don't know how to change them.

You can print Outlook calendars... What reasons are there that Outlook won't work? If these reasons were obvious, I wouldn't be asking.

https://support.microsoft.com/en-us/office/print-a-calendar-showing-appointments-and-meetings-ad03c408-1607-4a24-8b35-2c9f46930760

[wanderingfool2]

26 minutes ago, kirashi said:

You can print Outlook calendars... What reasons are there that Outlook won't work? If these reasons were obvious, I wouldn't be asking.

https://support.microsoft.com/en-us/office/print-a-calendar-showing-appointments-and-meetings-ad03c408-1607-4a24-8b35-2c9f46930760

I'd imagine getting a certain style or look can play into that

[Avocado Diaboli]

While I agree that you're probably better off just using Outlook (you can just hit Ctrl+P and print out any view you like from the print page) and not a VBA solution that neither you nor your replacement will have any knowledge about maintaining or fixing if something breaks, it was a fun exercice to get going.

 

I wrote a different routine that makes more use of arrays, because there's a lot of redundant stuff going on in your example. It also allows you to specify how many months you'd like to create.

 

Sub MakeCalendar()
    
    Dim myInput As Variant
    Dim mydate As Date
    Dim numMonths As Integer
    Dim i As Integer
    
    Application.ScreenUpdating = False
    
    Do
        myInput = InputBox("Type in the first Month and year for the Calendar (example: Jan 2020) ")
        
        If myInput = "" Then Exit Sub
        
        If Not IsDate(myInput) Then
            MsgBox "You may not have entered your Month and Year correctly." _
                & Chr(13) & "Spell the Month correctly" _
                & " (or use 3 letter abbreviation)" _
                & Chr(13) & "and 4 digits for the Year"
        End If
        
    Loop While Not IsDate(myInput)
    
    mydate = CDate(myInput)
   
    Do
        myInput = InputBox("How many months would you like to generate?")
        
        If myInput = "" Then Exit Sub
        
        If Not IsNumeric(myInput) Then
            MsgBox "Please enter a numeric value."
        End If
        
    Loop While Not IsNumeric(myInput)
    
    numMonths = myInput
    
    With ActiveSheet.Cells
        .Borders.LineStyle = xlLineStyleNone
        .Clear
    End With
    
    Range("A1").Select
    
    For i = 1 To numMonths
        Call MakeMonth(mydate)
        mydate = DateAdd("m", 1, mydate)
        ActiveCell.Offset(, 8).Select
    Next i
    
    Application.ScreenUpdating = True
     
End Sub

Sub MakeMonth(mydate)
    Dim days As Variant
    Dim firstWeekday As Integer
    Dim lenMonth As Integer
    Dim i As Integer
    Dim dayCounter As Integer
    Dim arrCalendar(42) As String
    Dim cell As Range
    
    Dim rngHeader As Range
    Dim rngDays As Range
    Dim rngDates As Range
    Dim rngMonth As Range
    
    With ActiveCell
        Set rngHeader = Range(ActiveCell, .Offset(, 6))
        Set rngDays = Range(.Offset(1), .Offset(1, 6))
        Set rngDates = Range(.Offset(2), .Offset(7, 6))
        Set rngMonth = Range(ActiveCell, .Offset(7, 6))
    End With

    firstWeekday = Weekday(mydate, vbSunday) - 1
    days = Array("S", "M", "T", "W", "T", "F", "S")
    
    With ActiveCell
        .NumberFormat = "MMMM YYYY"
        .Value = mydate
    End With

    With rngMonth
        .ColumnWidth = 3
        .VerticalAlignment = xlCenter
        .HorizontalAlignment = xlCenter
        .RowHeight = 20
    End With
    
    With rngHeader
        .HorizontalAlignment = xlCenterAcrossSelection
        .VerticalAlignment = xlCenter
        .RowHeight = 35
    End With
    
    Select Case Month(mydate)
        Case 2
            lenMonth = 27
        Case 4, 6, 9, 11
            lenMonth = 29
        Case Else
            lenMonth = 30
    End Select
        
    For i = firstWeekday To (firstWeekday + lenMonth)
        dayCounter = dayCounter + 1
        arrCalendar(i) = dayCounter
    Next i
       
    i = 0
    
    For Each cell In rngDays
        cell.Value = days(i)
        i = i + 1
    Next cell
    
    i = 0
    
    For Each cell In rngDates
        cell.Value = arrCalendar(i)
        i = i + 1
    Next cell
    
    For Each cell In rngMonth
        cell.BorderAround , xlThin, xlColorIndexAutomatic
    Next cell
    
End Sub

 

[airborne spoon]

7 hours ago, kirashi said:

You can print Outlook calendars... What reasons are there that Outlook won't work? If these reasons were obvious, I wouldn't be asking.

https://support.microsoft.com/en-us/office/print-a-calendar-showing-appointments-and-meetings-ad03c408-1607-4a24-8b35-2c9f46930760

Printing an outlook calendar is not what I'm trying to do because it looks like crap and is not suitable for my design.

I need 1 quarter at a time and I need them to be red and green and I need them to be small so I can type other things in the surrounding areas.

7 hours ago, wanderingfool2 said:

I'd imagine getting a certain style or look can play into that

Exactly

3 hours ago, Avocado Diaboli said:

While I agree that you're probably better off just using Outlook (you can just hit Ctrl+P and print out any view you like from the print page) and not a VBA solution that neither you nor your replacement will have any knowledge about maintaining or fixing if something breaks, it was a fun exercice to get going.

 

I wrote a different routine that makes more use of arrays, because there's a lot of redundant stuff going on in your example. It also allows you to specify how many months you'd like to create.

 

Sub MakeCalendar()
    
    Dim myInput As Variant
    Dim mydate As Date
    Dim numMonths As Integer
    Dim i As Integer
    
    Application.ScreenUpdating = False
    
    Do
        myInput = InputBox("Type in the first Month and year for the Calendar (example: Jan 2020) ")
        
        If myInput = "" Then Exit Sub
        
        If Not IsDate(myInput) Then
            MsgBox "You may not have entered your Month and Year correctly." _
                & Chr(13) & "Spell the Month correctly" _
                & " (or use 3 letter abbreviation)" _
                & Chr(13) & "and 4 digits for the Year"
        End If
        
    Loop While Not IsDate(myInput)
    
    mydate = CDate(myInput)
   
    Do
        myInput = InputBox("How many months would you like to generate?")
        
        If myInput = "" Then Exit Sub
        
        If Not IsNumeric(myInput) Then
            MsgBox "Please enter a numeric value."
        End If
        
    Loop While Not IsNumeric(myInput)
    
    numMonths = myInput
    
    With ActiveSheet.Cells
        .Borders.LineStyle = xlLineStyleNone
        .Clear
    End With
    
    Range("A1").Select
    
    For i = 1 To numMonths
        Call MakeMonth(mydate)
        mydate = DateAdd("m", 1, mydate)
        ActiveCell.Offset(, 8).Select
    Next i
    
    Application.ScreenUpdating = True
     
End Sub

Sub MakeMonth(mydate)
    Dim days As Variant
    Dim firstWeekday As Integer
    Dim lenMonth As Integer
    Dim i As Integer
    Dim dayCounter As Integer
    Dim arrCalendar(42) As String
    Dim cell As Range
    
    Dim rngHeader As Range
    Dim rngDays As Range
    Dim rngDates As Range
    Dim rngMonth As Range
    
    With ActiveCell
        Set rngHeader = Range(ActiveCell, .Offset(, 6))
        Set rngDays = Range(.Offset(1), .Offset(1, 6))
        Set rngDates = Range(.Offset(2), .Offset(7, 6))
        Set rngMonth = Range(ActiveCell, .Offset(7, 6))
    End With

    firstWeekday = Weekday(mydate, vbSunday) - 1
    days = Array("S", "M", "T", "W", "T", "F", "S")
    
    With ActiveCell
        .NumberFormat = "MMMM YYYY"
        .Value = mydate
    End With

    With rngMonth
        .ColumnWidth = 3
        .VerticalAlignment = xlCenter
        .HorizontalAlignment = xlCenter
        .RowHeight = 20
    End With
    
    With rngHeader
        .HorizontalAlignment = xlCenterAcrossSelection
        .VerticalAlignment = xlCenter
        .RowHeight = 35
    End With
    
    Select Case Month(mydate)
        Case 2
            lenMonth = 27
        Case 4, 6, 9, 11
            lenMonth = 29
        Case Else
            lenMonth = 30
    End Select
        
    For i = firstWeekday To (firstWeekday + lenMonth)
        dayCounter = dayCounter + 1
        arrCalendar(i) = dayCounter
    Next i
       
    i = 0
    
    For Each cell In rngDays
        cell.Value = days(i)
        i = i + 1
    Next cell
    
    i = 0
    
    For Each cell In rngDates
        cell.Value = arrCalendar(i)
        i = i + 1
    Next cell
    
    For Each cell In rngMonth
        cell.BorderAround , xlThin, xlColorIndexAutomatic
    Next cell
    
End Sub

 

Thanks, I'll take a look at this when I get to work and see what it looks like.

[airborne spoon]

this is what I'm working on making, obviously this is just October 3 times but you get the idea

 

[wanderingfool2]

The following excel is an example of how to quickly do it using formulas and conditional formatting  (There is a second tab showing conditional formatting)

 

Test.xlsx