Calendar in VBA

Question

I'm creating a VBA application that will ask a user a start date and end date and then will output monthly calendar in excel sheets.

Here, i have a code that asks the user for the month and year and then outputs this month in excel sheet

enter code here

Sub CalendarMaker()
ActiveSheet.Protect DrawingObjects:=False, Contents:=False, _
Scenarios:=False
Application.ScreenUpdating = False
On Error GoTo MyErrorTrap
Range("a1:g14").Clear
MyInput = InputBox("Type in Month and year for Calendar ")
If MyInput = "" Then Exit Sub
StartDay = DateValue(MyInput)
If Day(StartDay) <> 1 Then
StartDay = DateValue(Month(StartDay) & "/1/" & _
Year(StartDay))
End If
Range("a1").NumberFormat = "mmmm yyyy"
With Range("a1:g1")
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
.Font.Size = 18
.Font.Bold = True
.RowHeight = 35
End With
With Range("a2:g2")
.ColumnWidth = 11
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = xlHorizontal
.Font.Size = 12
.Font.Bold = True
.RowHeight = 20
End With
Range("a2") = "Sunday"
Range("b2") = "Monday"
Range("c2") = "Tuesday"
Range("d2") = "Wednesday"
Range("e2") = "Thursday"
Range("f2") = "Friday"
Range("g2") = "Saturday"
With Range("a3:g8")
.HorizontalAlignment = xlRight
.VerticalAlignment = xlTop
.Font.Size = 18
.Font.Bold = True
.RowHeight = 21
End With
Range("a1").Value = Application.Text(MyInput, "mmmm yyyy")
DayofWeek = Weekday(StartDay)
CurYear = Year(StartDay)
CurMonth = Month(StartDay)
FinalDay = DateSerial(CurYear, CurMonth + 1, 1)
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
For Each cell In Range("a3:g8")
RowCell = cell.Row
ColCell = cell.Column
If cell.Column = 1 And cell.Row = 3 Then
ElseIf cell.Column <> 1 Then
If cell.Offset(0, -1).Value >= 1 Then
cell.Value = cell.Offset(0, -1).Value + 1
If cell.Value > (FinalDay - StartDay) Then
cell.Value = ""
Exit For
End If
End If
ElseIf cell.Row > 3 And cell.Column = 1 Then
cell.Value = cell.Offset(-1, 6).Value + 1
If cell.Value > (FinalDay - StartDay) Then
cell.Value = ""
Exit For
End If
End If
Next
For x = 0 To 5
Range("A4").Offset(x * 2, 0).EntireRow.Insert
With Range("A4:G4").Offset(x * 2, 0)
.RowHeight = 65
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlTop
.WrapText = True
.Font.Size = 10
.Font.Bold = False
.Locked = False
End With
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
ActiveWindow.DisplayGridlines = False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, _
Scenarios:=True
ActiveWindow.WindowState = xlMaximized
ActiveWindow.ScrollRow = 1
Application.ScreenUpdating = True
Exit Sub
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

enter code here

But this code creates the calendar only for one specified month in one excel sheet,

but i want to to input several months and then the VBA should output several months in different excel sheets with one month in each of them.

I tried creating a while loop that outputs this whole code into different excel sheets, but it did not work out.

Here is the screenshot of the excel

"...but it did not work out." What didn't work out? Were there errors? Did you see strange output? — Marc, Nov 01 '15 at 18:39
@Marc It just did not work at all, i don't have much experience working with VBA and loops, so this is new for me — student123, Nov 01 '15 at 18:42

Dirk Reichel · Accepted Answer · 2015-11-02T13:15:13.717

something you can start with:

Sub CreateCalendar(StartDate As Integer, EndDate As Integer)
  Dim cRow As Byte, cCol As Byte
  cRow = Day(StartDate)
  cCol = 1
  For StartDate = StartDate To EndDate
    Cells(cRow, cCol).Value = StartDate
    'change active cell with "Cells(cRow, cCol)" like format or whatever
    If Month(StartDate) = Month(StartDate + 1) Then
      cRow = cRow + 1
      'same month but next day -> next row - increase "+ 1" if you ned more rows
    Else 'new month
      cRow = 1 'change to first row
      cCol = cCol + 1 
      'next column - increase "+ 1" if you ned more
    End If
  Next
End Sub

Edit: based on your edited question, try this:

Sub SetBord(bRng As Range) 'saves space in CreateCalendar cus its always the same pattern
  Dim x As Byte
  For x = 7 To 10
    bRng.Borders(x).LineStyle = 1
    bRng.Borders(x).ColorIndex = 0
    bRng.Borders(x).TintAndShade = 0
    bRng.Borders(x).Weight = -4138
  Next
End Sub

Sub CreateCalendar(StartDate As Long, Optional EndDate As Long)
  'check for input errors
  If StartDate < 1 Or EndDate < 0 Or StartDate > 2958465 Or EndDate > 2958465 Then
    MsgBox "Dates are out of range!"
    Exit Sub
        'if StartDate is after EndDate you still will get at least the first month
        'however, if you want, you can activate the next 3 lines
  'ElseIf EndDate > 0 And EndDate < StartDate Then
    'MsgBox "If EndDate is set, it needs to be after StartDate"
    'Exit Sub
  ElseIf (EndDate - StartDate) > 400 Then
    If MsgBox("Warning: Creating a calendar for a range of " & EndDate - StartDate & " days! Are You sure?", 4) = 7 Then Exit Sub
  End If
  Dim cRow As Long, cCol As Byte, x As Byte 'set variables
  StartDate = StartDate - Day(StartDate) + 1 'always create full months
  cRow = 1
  Do
    With Range(Cells(cRow, 1), Cells(cRow, 7)) 'month header
      .HorizontalAlignment = -4108
      .MergeCells = True
      .NumberFormat = "@"
      .Value = Format(StartDate, "MMMM yyyy")
    End With
    SetBord Range(Cells(cRow, 1), Cells(cRow, 7))
    cRow = cRow + 1
    For x = 1 To 7 'weekday header
      With Cells(cRow, x)
        .HorizontalAlignment = -4108
        .NumberFormat = "@"
        .Value = Format(x, "dddd")
      End With
    Next
    For x = 1 To 7 Step 2 'set all borders
      SetBord Range(Cells(cRow, x), Cells(cRow + 24, x))
    Next
    SetBord Range(Cells(cRow, 1), Cells(cRow, 7))
    cRow = cRow + 1
    For x = 4 To 20 Step 4
      SetBord Range(Cells(cRow + x, 1), Cells(cRow + x + 3, 7))
    Next
    cCol = (StartDate - 1) Mod 7 + 1
    Do 'set day numbers
      Cells(cRow, cCol).Value = Day(StartDate)
      StartDate = StartDate + 1
      If cCol = 7 Then
        cCol = 1
        cRow = cRow + 4
      Else
        cCol = cCol + 1
      End If
    Loop While Month(StartDate) = Month(StartDate - 1)
    cRow = cRow - ((cRow - 1) Mod 27) + 27
  Loop While EndDate > StartDate
End Sub

note: all months have the same height of 6 weeks at least i leave the font up to you :D

just using the smalest range that will fit... reducing memory usage :D — Dirk Reichel, Nov 01 '15 at 22:57
It's my understanding that in VBA we should use longs in place of integers due to the silent conversion in the background. http://stackoverflow.com/questions/26409117/why-use-integer-instead-of-long on a side note though, nice solution :) — Dan Donoghue, Nov 01 '15 at 23:02
just do as you like... while playing with vba there will no real impact... its... a habit :D — Dirk Reichel, Nov 01 '15 at 23:11
Wow, that is incredible ! Thank you so much ! It helped a lot ! — student123, Nov 05 '15 at 04:12

Calendar in VBA

1 Answers1