Excel's Magic Calendar

[djl0525]

For over a decade I've missed two things in Excel. (Okay, I've really missed more than two, but this post is about the two that are on my mind at this moment.) One, a ruler like in Word and PowerPoint. And two, a Make Calendar button that lets you select a list of events, dates in the one column, text in the other column, and when you click the magic button it displays the list in a calendar layout. I see they added the ruler in 2007. Yipee! I'm still looking the magic Make Calendar button??? (I'm not looking for a blank calendar... I've seen the templates.) I want to turn my list into a calendar.

What are your favorite ways to calendarize Excel data?

--DJ

 

[djl0525]

Tom3, I have not found it. I don't think it exists and that really puzzles me because I think it should be natural to view a list of dates in a calendar layout.

Since you "need a solution bad", I'll give you a link to the file I've been using for about 5 years now. Created by Chip Pearson in 1988, this workbook will convert a list of dates to a calendar layout. I had to do a lot of tweaking to make it work for me because my worksheet is linked to an Oracle database, blah, blah, blah, but it may be simpler for you.

To download the file, scroll down to Calendar on this page.
http://www.cpearson.com/excel/Download.htm

Good luck! Let me know what you think!

Still looking for that magic button,
--DJ

 

[WaxonWaxov]

New to this forum... can I attach a file?

I think I have the solution... I am working in Excel 2007

 

[djl0525]

You can't attach files to forum posts, but you can attach files to private messages within MrExcel. Or you can post the file to a free file hosting like box.net and put a link to the file here in the forum.

--DJ

 

[TKWaiting]

New to this forum... can I attach a file?

I think I have the solution... I am working in Excel 2007

Were you ever able to figure this out and if so, can you share the document?

Thanks...

 

[NoMoreMrNiceGuy]

I'm not one to let a good thread die

I want to do this same thing; make a custom Excel calendar and have my list of dates-events imported auto-magically. I've tried the Outlook and Google calendars, and the Excel calendars, and although I can make them work, I am not satisfied with them. I made my own Excel calendar but I have to remake it each year, and enter events into it manually. This invariably results in a mistake or 2 each year. So I decided to revisit this thread in case someone more imaginative than me has come up with something. TIA

 

[Logit]

djl0525

The download is missing from the website.

 

[Perpa]

I'm not one to let a good thread die
make a custom Excel calendar and have my list of dates-events imported auto-magically. TIA

TIA,

I used 6 macros and the calendar worksheet shown below to show the appropriate holidays for the month selected from a drop down in cell J4:
MyHolidays, CalcDay, IsLeapYear, Remove6thCalendarRow, sixthweek, and a Worksheet_Change event

The first 5 macros can be put in a standard code module. The Worksheet Change event must be placed in a worksheet module on the same worksheet as the calendar is displayed. When a
month is selected from the drop down in cell J4 on the Calendar sheet, the code is run and the Calendar is updated for that month complete with events/holidays. The holiday dates and descriptons could be changed to whatever event you want.

The MyHolidays code is looking for the event/holiday list to start in cell J7 and continue to the Last used Row in column J on the same sheet where the calendar is shown. You can modify the code if you want the list in a different location, but you will have to change the 'J' and 'K' references in the FOR/NEXT loop accordingly.

The code changes the dates for the selected month and inserts the selected month's events/holidays if any. It also determines if there are 5 or 6 weeks in the month and adds or deletes the 6th week to the calendar.
Perpa

This is the calendar: (doesn't appear to be posting correctly. I'll try and post a link to the file)

Sub MyHolidays()
Dim rw1, rw2, col, LastRow As Long
Dim myDay
Dim MonthNum As Integer
Dim myMonth As String
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
LastRow = Range("J" & Rows.Count).End(xlUp).Row
For rw1 = 7 To LastRow
    MonthNum = Month(Cells(rw1, "J"))     'Gives the number of the month, ie. 1, 2 to 12
    If MonthNum = 1 Then myMonth = "JANUARY"
    If MonthNum = 2 Then myMonth = "FEBRUARY"
    If MonthNum = 3 Then myMonth = "MARCH"
    If MonthNum = 4 Then myMonth = "APRIL"
    If MonthNum = 5 Then myMonth = "MAY"
    If MonthNum = 6 Then myMonth = "JUNE"
    If MonthNum = 7 Then myMonth = "JULY"
    If MonthNum = 8 Then myMonth = "AUGUST"
    If MonthNum = 9 Then myMonth = "SEPTEMBER"
    If MonthNum = 10 Then myMonth = "OCTOBER"
    If MonthNum = 11 Then myMonth = "NOVEMBER"
    If MonthNum = 12 Then myMonth = "DECEMBER"
    
    If Cells(4, "J") = myMonth Then   'Determines if any holidays in current MONTH
        myDay = Day(Cells(rw1, "J"))
        For rw2 = 8 To 23 Step 3
             For col = 2 To 8
                 If myDay = Cells(rw2, col) Then
                     Cells(rw2, col).Offset(1, 0) = Cells(rw1, "K")
                     Cells(rw2, col).Offset(2, 0).ClearContents
                     GoTo PASSEM
                 End If
              Next
        Next
    End If
PASSEM:
Next
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Sub CalcDay()
    Dim d As Integer
    Dim dy As Integer
    Dim LastDay As Integer
    Dim col As Integer
    Dim cl As Integer
    Dim lday As Integer
    Dim n As Integer
    
    Application.ScreenUpdating = False
    
    'Sets the day of the week that is the 1st of the month
        d = Application.Weekday(Cells(4, 6) & " 1, " & Cells(4, 8))
    
    Sheet1.Range("B8:H8").ClearContents  'Clears Calendar
    LastDay = 8 - d
    
        For dy = 1 To LastDay
             col = d + dy
             Cells(8, col) = dy
        Next dy
 'The following sets the days in weeks 2, 3, and 4
Cells(11, 2) = Cells(8, 8) + 1 'Week 2
    For n = 3 To 8
        Cells(11, n) = Cells(11, n - 1) + 1
    Next n
Cells(14, 2) = Cells(11, 2) + 7 'Week 3
    For n = 3 To 8
        Cells(14, n) = Cells(14, n - 1) + 1
    Next n
Cells(17, 2) = Cells(14, 2) + 7 'Week 4
    For n = 3 To 8
        Cells(17, n) = Cells(17, n - 1) + 1
    Next n
'The following sets the days in weeks 5 and 6 dependent on the month and Leap Year
Cells(20, 2) = Cells(17, 8) + 1
For n = 3 To 8
Cells(20, n) = Cells(20, n - 1) + 1
Next n
Cells(23, 2) = Cells(20, 8) + 1
Cells(23, 3) = Cells(23, 2) + 1
If IsLeapYear(Cells(4, 8)) And Cells(4, 6) = "FEBRUARY" Then lday = 29
If Not IsLeapYear(Cells(4, 8)) And Cells(4, 6) = "FEBRUARY" Then lday = 28
If Cells(4, 6) = "APRIL" Then lday = 30
If Cells(4, 6) = "JUNE" Then lday = 30
If Cells(4, 6) = "SEPTEMBER" Then lday = 30
If Cells(4, 6) = "NOVEMBER" Then lday = 30
If Cells(4, 6) = "JANUARY" Then lday = 31
If Cells(4, 6) = "MARCH" Then lday = 31
If Cells(4, 6) = "MAY" Then lday = 31
If Cells(4, 6) = "JULY" Then lday = 31
If Cells(4, 6) = "AUGUST" Then lday = 31
If Cells(4, 6) = "OCTOBER" Then lday = 31
If Cells(4, 6) = "DECEMBER" Then lday = 31
For cl = 2 To 8
    If Cells(20, cl) > lday Then Cells(20, cl).ClearContents
    If Cells(23, cl) > lday Then Cells(23, cl).ClearContents
    
Next cl
    
    If Cells(23, 2) = "" Then
        Call Remove6thCalendarRow
    Else
   'Puts borders and fill back if 6th row used
        Range("B23:B25").Select
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = -4.99893185216834E-02
            .PatternTintAndShade = 0
        End With
        Call sixthweek
        
        Range("C23:C25").Select
        Call sixthweek
    End If
    
    Call MyHolidays
    Range("J6").Select
    Application.ScreenUpdating = True
End Sub
Public Function IsLeapYear(Y As Integer)
     IsLeapYear = Month(DateSerial(Y, 2, 29)) = 2
 End Function

Sub Remove6thCalendarRow()
' delete borders in last row
'
    Range("B23:C25").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("B22:C22").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("B23:B25").Select
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
End Sub

Sub sixthweek()
' Puts borders back on last (6th) Week
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
'Redate calendar for selected MONTH or if the YEAR is changed
    If Target.Address = "$J$4" Then CalcDay
    If Target.Address = "$H$4" Then CalcDay
End Sub

 

[Perpa]

TIA,

Here is the link to the Box.com file:

https://app.box.com/s/b5u2l6zwmphmj6peeuuog7rzhzz7p63b

Not sure why the earlier post did not work. Hopefully this will work.

Perpa

 

[GuardianEnzo]

Thanks for sharing Perpa, the calendar is very well put together.
If I wanted it to be able to show 2 or more events/holidays on the same date, how could I edit the code to reflect this?

 

[Perpa]

GuardianEnzo... Welcome to the Forum.
I appreciate the feedback, and you are welcome.

'To show 2 or more events/holidays on the same date...', try replacing this code snippet:

             For col = 2 To 8
                 If myDay = Cells(rw2, col) Then
                     Cells(rw2, col).Offset(1, 0) = Cells(rw1, "K")
                     Cells(rw2, col).Offset(2, 0).ClearContents
                     GoTo PASSEM
                 End If
              Next

With this:

             For col = 2 To 8
                 If myDay = Cells(rw2, col) Then
                       If Cells(rw2, col).Offset(1, 0) = "" then
                            Cells(rw2, col).Offset(1, 0) =  Cells(rw1, "K")
                       Else
                            Cells(rw2, col).Offset(1, 0) = Cells(rw2, col).Offset(1, 0) & Chr(10) & Cells(rw1, "K")
                            Cells(rw2, col).Offset(1, 0).Rows.AutoFit
                       End If
                     Cells(rw2, col).Offset(2, 0).ClearContents
                     GoTo PASSEM
                 End If
              Next

You may want to reset the row height (29.5) when the month changes and the events are erased. You can do that manually or with code. You may also want to use the bottom row of each pair in each date. I used the bottom rows for drop down entries. I'll let you play with that on your own. Should be something similar to what I just provided for the top rows. Have fun! And thanks again for the feedback.
Perpa