Creating Calendars

**dangelor** · 12-11-2011, 05:09 PM

Searching the web for a VBA solution for creating a calendar, I found one on a Microsoft site (http://support.microsoft.com/kb/150774).

Their solution has a very laborious way to place the numbers into the calendar grid.

Here is my simpler solution.

' Loop through range a7:g12 incrementing each cell. dtFinalDay = 1st day on next month, dtStartDay = 1st day of current month.
        For x = 1 To (dtFinalDay - dtStartDay + intDayofWeek - 1)
            If x >= intDayofWeek Then .Range("A7:G12")(x) = x - intDayofWeek + 1
        Next x

Microsoft's code:

      ' 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

**snb** · 12-11-2011, 06:04 PM

According to the ISO system, december 2011:

sub snb()
 sn = [A7:G12]

 For j = 1 To [A7:G12].Count
  sn(((j - 1) \ 7) + 1, (j - 1) Mod 7 + 1) = DateSerial(2011, 12, 1) - DatePart("w", DateSerial(2011, 12, 1), 2) + 7 * ((j - 1) \ 7) + (j - 1) Mod 7 + 1
 Next

 [A7:G12] = sn
end sub

**dangelor** · 12-13-2011, 11:30 PM

snb,
Your code places a date in the cells, not the day number, and fills every cell. My code (and Microsoft's) will only populate those cells that correspond to the actual days of the current month with the day number.

**abousetta** · 12-13-2011, 11:57 PM

I don't see a question in the original post. If you are sharing your updated code (which I thank you for), please add an example workbook so we can see the results. Also this thread is probably better for the Water Cooler rather here. You can PM one of the moderators to move it.

Hope this helps.

abousetta

**dangelor** · 12-14-2011, 10:16 AM

As suggested, attached is a simple calendar using code. Change the selections in the drop down cells to create calendar.

Sub QuickCalendar()
    Dim x As Integer, intDayofWeek As Integer
    Dim dtFinalDay As Date, dtStartDay As Date, dtCurrentDate As Date
    
    With Worksheets("Calendar")
        .Range("A7:G12").Clear
        
        dtCurrentDate = .Range("a5")
        dtFinalDay = DateSerial(Year(dtCurrentDate), Month(dtCurrentDate) + 1, 1)
        dtStartDay = DateSerial(Year(dtCurrentDate), Month(dtCurrentDate), 1)
        intDayofWeek = Weekday(dtStartDay)


        For x = 1 To (dtFinalDay - dtStartDay + intDayofWeek - 1)
            If x >= intDayofWeek Then .Range("A7:G12")(x) = x - intDayofWeek + 1
        Next x
    End With
End Sub