SynapSonic Software

Whilst creating various turn-around-time reports, I thought it would be helpful to add a little calendar to the spreadsheet.  Here is an excel vba function that adds a mini calendar to the cell address you specify:

 Public Function MakeCalendar(intStartRow As Integer, intStartCol As Integer, strStartDate As String, strEnddate As String) As Boolean
    'Takes start row and column and prints a calendar. By Eric Ainsworth - www.synapsonic.com
    On Error GoTo Errorhandler
    Dim WeekDays() As String 'little array for S-Sat
    WeekDays = Split("Sun,Mon,Tue,Wed,Thu,Fri,Sat", ",")
    Dim intX As Integer
    Dim intY As Integer
    Dim intCals As Integer
    Dim strMonth As String
    Dim intRow As Integer
    Dim intDay As Integer
    Dim intMonths As Integer
    If Month(strStartDate) = Month(strEnddate) Then
        'Same month
        intMonths = 1
    Else
        ‘Only set up to handle 2 months here.
        intMonths = 2
    End If

    For intCals = 1 To intMonths 'just once if same month
        If intCals = 1 Then 'first month
            strMonth = Month(strStartDate)
        Else
            strMonth = Month(strEnddate)
        End If

        If intCals > 1 Then 'move everythuing over to right
            intStartCol = intStartCol + 7
        End If

        For intY = LBound(WeekDays) To UBound(WeekDays)
            Cells(intStartRow + 1, intStartCol + intY).Value = WeekDays(intY)
            If intY = 3 Then 'put month
                If intCals = 1 Then
                    Cells(intStartRow, intStartCol + intY).Value = Format(strStartDate, "mmm")
                Else
                    Cells(intStartRow, intStartCol + intY).Value = Format(strEnddate, "mmm")
                End If 'end if intcals
            End If 'end if wed

            Range(Cells(intStartRow, intStartCol + intY), Cells(intStartRow + 1, intStartCol + intY)).Select
            Selection.HorizontalAlignment = xlCenter
            With Selection.Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorDark1
                .TintAndShade = -0.149998474074526
                .PatternTintAndShade = 0
            End With
        Next intY 'next weekday

        intStartRow = intStartRow + 1

        intRow = 0
        For intX = 1 To 31 'day of month
            If Not IsDate(strMonth & " " & Format(CStr(intX), "00") & " " & Year(strStartDate)) Then
                Debug.Print "MakeCalendar: Last day of month " & strMonth & " was: " & intX - 1
                'Debug.Print strMonth & " " & Format(CStr(intX), "00") & " " & Year(strStartDate) & " not a date"
                Exit For
            End If

            intDay = Weekday(strMonth & " " & Format(CStr(intX), "00") & " " & Year(strStartDate)) 'as it is this will break over new years

            Cells(intStartRow + intRow + 1, intDay + intStartCol - 1).Value = intX
            Cells(intStartRow + intRow + 1, intDay + intStartCol - 1).HorizontalAlignment = xlCenter

            If DateDiff("d", strMonth & " " & Format(CStr(intX), "00") & " " & Year(strStartDate), strStartDate) = 0 Or DateDiff("d", strMonth & " " & Format(CStr(intX), "00") & " " & Year(strStartDate), strEnddate) = 0 Then
                Cells(intStartRow + intRow + 1, intDay + intStartCol - 1).Font.Bold = True
            End If

            'Columns(intDay + intStartCol - 1).EntireColumn.AutoFit 'cant do this it messes up stuff above

            Select Case intDay
                Case 1 'sunday
                    Cells(intStartRow + intRow + 1, intDay + intStartCol - 1).Borders(xlEdgeLeft).LineStyle = xlContinuous
                Case 2 'monday
                Case 3
                Case 4 'wed
                Case 5 'thur
                Case 6 'fri
                Case 7 'sat
                        Cells(intStartRow + intRow + 1, intDay + intStartCol - 1).Borders(xlEdgeRight).LineStyle = xlContinuous
                        intRow = intRow + 1
            End Select

        Next intX 'next day

        intStartRow = intStartRow - 1
    Next intCals 'next calendar

    Exit Function
Errorhandler:
    Debug.Print Err.Description & " " & Err.Number
    Resume Next
End Function

 

This is how you would call it:

 

Public Sub Test()
    Debug.Print MakeCalendar(1, 1, "5/1/2012", "5/31/2012")
End Sub