Excel - Create Yearly Calendar

This macro creates an annual calendar.

Excel

5893
1867
0
0

Add to collection

1 Open MS Excel.

2 Create a blank workbook.

3 Go to Developer's tab > click on "Visual Basic" button or hit Alt + F11.

4 Go to Insert tab > click on "Module" or hit M.

5 Copy the VBA code from below.

6 Paste the code in the newly created module.

7 Go to Run tab > click on "Run Sub/UserForm" or hit F5.

8 That's it!

Code

Option Explicit
'==========================================
' Create Yearly Calendar
'==========================================
Sub createYearlyCalendar()
    ' Declare variables
    Dim strMessage As String
    Dim strTitle As String
    Dim strPlaceholder As String
    Dim ws As Worksheet
    Dim intYear As Integer
    Dim bytMonth As Byte
    Dim strMonth As String
    Dim bytDay As Byte
    Dim bytWeekday As Byte
    Dim strWeekday As String
    Dim bytWeekNo As Byte
    Dim bytDummy As Byte
    ' Set input box properties
    ' Set message
    strMessage = "Please type a year."
    ' Set title
    strTitle = "Create new calendar"
    ' Placeholder for year
    strPlaceholder = "2020"
    ' Get typed year
    intYear = Application.InputBox(strMessage, strTitle, strPlaceholder, Type:=1)
    ' Check if typed year is false
    If intYear = False Then
        ' Exit sub
        Exit Sub
    End If
    ' Stop screen updating
    Application.ScreenUpdating = False
    ' Clear gridlines
    ThisWorkbook.Worksheets(1).Activate
    ActiveWindow.DisplayGridlines = False
    ' Delete content
    With ThisWorkbook.Worksheets(1)
        Range("A1:L32").Clear
    End With
    ' Give the worksheet a new name
    ActiveSheet.Name = "Year " & intYear
    ' Set months, title and styles
    ' Loop from 1 to 12
    For bytMonth = 1 To 12
        ' Set months in text format
        Select Case bytMonth
           Case 1
              strMonth = "January"
           Case 2
              strMonth = "February"
           Case 3
              strMonth = "March"
           Case 4
              strMonth = "April"
           Case 5
              strMonth = "May"
           Case 6
              strMonth = "June"
           Case 7
              strMonth = "July"
           Case 8
              strMonth = "August"
           Case 9
              strMonth = "September"
           Case 10
              strMonth = "Oktober"
           Case 11
              strMonth = "November"
           Case 12
              strMonth = "December"
        End Select
        ' Format month cells
        With Cells(1, bytMonth)
           .Value = Format(DateSerial(intYear, bytMonth, 1), "mmmm")
           .Value = strMonth
           .Style = "Check Cell"
           .Font.Bold = True
           .Font.Italic = True
           .EntireColumn.AutoFit
        End With
        ' Set days in text format
        For bytDay = 1 To Day(DateSerial(intYear, bytMonth + 1, 0))
            With Cells(bytDay + 1, bytMonth)
                ' Get week day
                bytWeekday = Weekday(DateSerial(intYear, bytMonth, bytDay))
                ' Set days in text format
                Select Case bytWeekday
                   Case 1
                      strWeekday = "Sunday"
                   Case 2
                      strWeekday = "Monday"
                   Case 3
                      strWeekday = "Tuesday"
                   Case 4
                      strWeekday = "Wednesday"
                   Case 5
                      strWeekday = "Thursday"
                   Case 6
                      strWeekday = "Friday"
                   Case 7
                      strWeekday = "Saturday"
                End Select
                ' Format weekends and workdays
                .Value = strWeekday & ", " & bytDay
                Range("A2:L32").Select
                Selection.Borders(xlDiagonalDown).LineStyle = xlNone
                Selection.Borders(xlDiagonalUp).LineStyle = xlNone
                With Selection.Borders(xlEdgeLeft)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                With Selection.Borders(xlEdgeTop)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                With Selection.Borders(xlEdgeBottom)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                With Selection.Borders(xlEdgeRight)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                With Selection.Borders(xlInsideVertical)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                With Selection.Borders(xlInsideHorizontal)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                ' Saturdays style
                If bytWeekday = 7 Then
                   .Style = "Neutral"
                   .Font.Italic = True
                   .EntireColumn.AutoFit
                End If
                ' Sundays style
                If bytWeekday = 1 Then
                   .Style = "Good"
                   .Font.Italic = True
                   .EntireColumn.AutoFit
                End If
                ' Import weeks
                ' Get week number
                bytWeekNo = Format(DateSerial(intYear, bytMonth, bytDay), "ww")
                If bytDummy < bytWeekNo And strWeekday <> "Sunday" Then
                   bytDummy = bytWeekNo
                   .Value = .Value & " (" & bytDummy & ")"
                   ' Weeks style
                   With .Characters(Start:=InStr(1, .Value, "("), Length:=4).Font
                      .Size = 8
                      .ColorIndex = 16
                   End With
                End If
            End With
        Next bytDay
    Next bytMonth
    ' Select a neutral cell
    ThisWorkbook.Worksheets(1).Range("N3").Select
    ' Start screen updating
    Application.ScreenUpdating = True
    ' Calendar successfully created
    MsgBox "Your calendar for " & intYear & " was successfully created!", vbInformation
End Sub