Creating a mini calendar inside an excel spreadsheet
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
