VB Calendar Macro to highlight current date

**jlcford** · 10-08-2008, 10:23 AM

I have a macro that displays a calendar with code to highlight the current date, but this part of the code does not work and the current date is not highlighted.

Sub CalendarMaker()

      ' Unprotect sheet if had previous calendar to prevent error.
       ActiveSheet.Protect DrawingObjects:=False, Contents:=False, _
          Scenarios:=False
       ' Prevent screen flashing while drawing calendar.
       Application.ScreenUpdating = False
       ' Set up error trapping.
       On Error GoTo MyErrorTrap
       ' Clear area c5:am5 including any previous calendar.
       Range("C5:AM5").Clear
       ' Use InputBox to get desired month and year and set variable
       ' MyInput.
       MyInput = InputBox("Type in Month and year for Calendar ")
       ' Allow user to end macro with Cancel in InputBox.
       If MyInput = "" Then Exit Sub
       ' Get the date value of the beginning of inputted month.
       StartDay = DateValue(MyInput)
       ' Check if valid date but not the first of the month
       ' -- if so, reset StartDay to first day of month.
       If DAY(StartDay) <> 1 Then
           StartDay = DateValue(Month(StartDay) & "/1/" & _
               Year(StartDay))
       End If
       ' Prepare cell for Month and Year as fully spelled out.
       Range("C5").NumberFormat = "mmmm yyyy"
       ' Center the Month and Year label across c5:am5 with appropriate
       ' size, height and bolding.
       With Range("C5:AM5")
           .ColumnWidth = 2.57
           .HorizontalAlignment = xlCenterAcrossSelection
           .VerticalAlignment = xlCenter
           .Font.Size = 18
           .Font.Bold = True
           .RowHeight = 35
       End With
       
       ' Prepare C7:AM7 for dates with center alignment, size, height
       ' and bolding.
       With Range("C7:AM7")
           .ColumnWidth = 2.57
           .HorizontalAlignment = xlCenter
           .VerticalAlignment = xlCenter
           .Font.Size = 10
           .Font.Bold = True
           .RowHeight = 12.75
       End With
       ' Put inputted month and year fully spelling out into "c5".
       Range("C5").Value = Application.Text(MyInput, "mmmm yyyy")
       ' Set variable and get which day of the week the month starts.
       DayofWeek = Weekday(StartDay)
       ' Set variables to identify the year and month as separate
       ' variables.
       CurYear = Year(StartDay)
       CurMonth = Month(StartDay)
       ' Set variable and calculate the first day of the next month.
       FinalDay = DateSerial(CurYear, CurMonth + 1, 1)
       ' Place c "1" in cell position of the first day of the chosen
       ' month based on DayofWeek.
       Select Case DayofWeek
           Case 1
               Range("C7").Value = 1
           Case 2
               Range("D7").Value = 1
           Case 3
               Range("E7").Value = 1
           Case 4
               Range("F7").Value = 1
           Case 5
               Range("G7").Value = 1
           Case 6
               Range("H7").Value = 1
           Case 7
               Range("I7").Value = 1
       End Select
       ' Loop through range C7:AM7 incrementing each cell after the "1"
       ' cell.
       For Each cell In Range("C7:AM7")
           ColCell = cell.Column
           ' Do if "1" is in first column.
           If cell.Column = 1 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
             ' 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
    
    For Each cell In Range("C7:AM7")

        If cell.Value = "=TODAY()" Then
        
            With Range("C7:AM7")
                .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=Today()"
                .FormatConditions(1).Interior.ColorIndex = 1
            End With
        
        End If
    Exit For
    
   Next
    
      
      ' Turn on gridlines
       ActiveWindow.DisplayGridlines = True
       ' Protect sheet to prevent overwriting the dates.
       ActiveSheet.Protect DrawingObjects:=True, Contents:=True, _
          Scenarios:=True

       ' Prevent going to error trap unless error found by exiting Sub
       ' here.
       Exit Sub
   ' Error causes msgbox to indicate the problem, provides new input box,
   ' and resumes at the line that caused the error.
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

Suggestions?

Thanks,
jlcford

**royUK** · 10-08-2008, 10:46 AM

What format is the inputbox expecting because it won't accept any variation of dates that I have tried.

**jlcford** · 10-08-2008, 10:54 AM

I sorry I don't quite understand your question. I start out with a blank worksheet. I run the macro and type in the month and year of the calendar month I want to display. The Month and Year are displayed along with the dates 1 - 30 or 31 in cells C7:AM7 depending on what day of the week the month begins with.

jlcford

**royUK** · 10-08-2008, 10:59 AM

When the prompt for month & year comes up, what do you type in. I have tried 12/2008 and December 2008 and Dec 2008, all bring up the error message

**jlcford** · 10-08-2008, 11:10 AM

"October 2008"

That is how the program is written. It only accepts that type of input.

**royUK** · 10-08-2008, 11:28 AM

Your Conditional Formatting can't work, the cells do not contain a date

**jlcford** · 10-08-2008, 11:38 AM

Any suggestions on how to get them to show a date?

jlcford

**royUK** · 10-08-2008, 11:38 AM

Try this

Sub CalendarMaker()

      ' Unprotect sheet if had previous calendar to prevent error.
       ActiveSheet.Protect DrawingObjects:=False, Contents:=False, _
          Scenarios:=False
       ' Prevent screen flashing while drawing calendar.
       Application.ScreenUpdating = False
       ' Set up error trapping.
      On Error GoTo MyErrorTrap
       ' Clear area c5:am5 including any previous calendar.
       Range("C5:AM5").Clear
       ' Use InputBox to get desired month and year and set variable
       ' MyInput.
       MyInput = InputBox("Type in Month and year for Calendar ")
       ' Allow user to end macro with Cancel in InputBox.
       If MyInput = "" Then Exit Sub
       ' Get the date value of the beginning of inputted month.
       StartDay = DateValue(MyInput)
       ' Check if valid date but not the first of the month
       ' -- if so, reset StartDay to first day of month.
       If Day(StartDay) <> 1 Then
           StartDay = DateValue(Month(StartDay) & "/1/" & _
               Year(StartDay))
       End If
       ' Prepare cell for Month and Year as fully spelled out.
       Range("C5").NumberFormat = "mmmm yyyy"
       ' Center the Month and Year label across c5:am5 with appropriate
       ' size, height and bolding.
       With Range("C5:AM5")
           .ColumnWidth = 2.57
           .HorizontalAlignment = xlCenterAcrossSelection
           .VerticalAlignment = xlCenter
           .Font.Size = 18
           .Font.Bold = True
           .RowHeight = 35
       End With
       
       ' Prepare C7:AM7 for dates with center alignment, size, height
       ' and bolding.
       With Range("C7:AM7")
           .ColumnWidth = 2.57
           .HorizontalAlignment = xlCenter
           .VerticalAlignment = xlCenter
           .Font.Size = 10
           .Font.Bold = True
           .RowHeight = 12.75
       End With
       ' Put inputted month and year fully spelling out into "c5".
       Range("C5").Value = Application.Text(MyInput, "mmmm yyyy")
       ' Set variable and get which day of the week the month starts.
       DayofWeek = Weekday(StartDay)
       ' Set variables to identify the year and month as separate
       ' variables.
       CurYear = Year(StartDay)
       CurMonth = Month(StartDay)
       ' Set variable and calculate the first day of the next month.
       FinalDay = DateSerial(CurYear, CurMonth + 1, 1)
       ' Place c "1" in cell position of the first day of the chosen
       ' month based on DayofWeek.
       Select Case DayofWeek
           Case 1
               Range("C7").Value = 1
           Case 2
               Range("D7").Value = 1
           Case 3
               Range("E7").Value = 1
           Case 4
               Range("F7").Value = 1
           Case 5
               Range("G7").Value = 1
           Case 6
               Range("H7").Value = 1
           Case 7
               Range("I7").Value = 1
       End Select
       ' Loop through range C7:AM7 incrementing each cell after the "1"
       ' cell.
       For Each cell In Range("C7:AM7")
           ColCell = cell.Column
           ' Do if "1" is in first column.
           If cell.Column = 1 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
             ' 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
    
        
            With Range("C7:AM7")
                .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
        Formula1:="=DAY(TODAY())"
                .FormatConditions(1).Interior.ColorIndex = 1
            End With
        
           ' Turn on gridlines
       ActiveWindow.DisplayGridlines = True
       ' Protect sheet to prevent overwriting the dates.
       ActiveSheet.Protect DrawingObjects:=True, Contents:=True, _
          Scenarios:=True

       ' Prevent going to error trap unless error found by exiting Sub
       ' here.
       Exit Sub
   ' Error causes msgbox to indicate the problem, provides new input box,
   ' and resumes at the line that caused the error.
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
Sub Macro123()
'

**jlcford** · 10-08-2008, 12:22 PM

I get a runtime error with this line of code.

Selection.FormatConditions(1).Interior.ColorIndex = 34

The problem with using the reference DAY() (I have tried this before), is if I am looking in another calendar not the current month it highlights the "interger" of the current Day whether it is in the current month or not.

There has to be a way to write the code to populate the calendar days so they can be recognized as TODAY() - I am just haven't been able to figure it out.

jlcford

**royUK** · 10-09-2008, 06:16 AM

This works fine for me

Sub CalendarMaker()

    ' Unprotect sheet if had previous calendar to prevent error.
    ActiveSheet.Protect DrawingObjects:=False, Contents:=False, _
                        Scenarios:=False
    ' Prevent screen flashing while drawing calendar.
    Application.ScreenUpdating = False
    ' Set up error trapping.
    On Error GoTo MyErrorTrap
    ' Clear area c5:am5 including any previous calendar.
    Range("C5:AM5").Clear
    ' Use InputBox to get desired month and year and set variable
    ' MyInput.
    MyInput = InputBox("Type in Month and year for Calendar ")
    ' Allow user to end macro with Cancel in InputBox.
    If MyInput = "" Then Exit Sub
    ' Get the date value of the beginning of inputted month.
    StartDay = DateValue(MyInput)
    ' Check if valid date but not the first of the month
    ' -- if so, reset StartDay to first day of month.
    If Day(StartDay) <> 1 Then
        StartDay = DateValue(Month(StartDay) & "/1/" & _
                             Year(StartDay))
    End If
    ' Prepare cell for Month and Year as fully spelled out.
    Range("C5").NumberFormat = "mmmm yyyy"
    ' Center the Month and Year label across c5:am5 with appropriate
    ' size, height and bolding.
    With Range("C5:AM5")
        .ColumnWidth = 2.57
        .HorizontalAlignment = xlCenterAcrossSelection
        .VerticalAlignment = xlCenter
        .Font.Size = 18
        .Font.Bold = True
        .RowHeight = 35
    End With

    ' Prepare C7:AM7 for dates with center alignment, size, height
    ' and bolding.
    With Range("C7:AM7")
        .ColumnWidth = 2.57
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Font.Size = 10
        .Font.Bold = True
        .RowHeight = 12.75
    End With
    ' Put inputted month and year fully spelling out into "c5".
    Range("C5").Value = Format(MyInput, "mmmm yyyy")
    ' Set variable and get which day of the week the month starts.
    DayofWeek = Weekday(StartDay)
    ' Set variables to identify the year and month as separate
    ' variables.
    CurYear = Year(StartDay)
    CurMonth = Month(StartDay)
    ' Set variable and calculate the first day of the next month.
    FinalDay = DateSerial(CurYear, CurMonth + 1, 1)
    ' Place c "1" in cell position of the first day of the chosen
    ' month based on DayofWeek.
    Select Case DayofWeek
        Case 1
            Range("C7").Value = 1
        Case 2
            Range("D7").Value = 1
        Case 3
            Range("E7").Value = 1
        Case 4
            Range("F7").Value = 1
        Case 5
            Range("G7").Value = 1
        Case 6
            Range("H7").Value = 1
        Case 7
            Range("I7").Value = 1
    End Select
    ' Loop through range C7:AM7 incrementing each cell after the "1"
    ' cell.
    For Each cell In Range("C7:AM7")
        ColCell = cell.Column
        ' Do if "1" is in first column.
        If cell.Column = 1 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
            ' 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


    With Range("C7:AM7")
        .FormatConditions.Delete
        .FormatConditions.Add Type:=xlExpression, Formula1:= _
                              "=month($c$5)<>month(today())"
        .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
                              Formula1:="=day(today())"
        .FormatConditions(2).Interior.ColorIndex = 1
    End With

    ' Turn on gridlines
    ActiveWindow.DisplayGridlines = True
    ' Protect sheet to prevent overwriting the dates.
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, _
                        Scenarios:=True

    ' Prevent going to error trap unless error found by exiting Sub
    ' here.
    Exit Sub
    ' Error causes msgbox to indicate the problem, provides new input box,
    ' and resumes at the line that caused the error.
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

**jlcford** · 10-10-2008, 08:07 AM

Sorry for the delay in my response. I was out of the office yesterday. Yes, you are correct this code works perfectly. Thanks for the help.

jlcford

**royUK** · 10-10-2008, 08:25 AM

Glad it worked for you

**jlcford** · 10-10-2008, 11:09 AM

When I began working on my calendar I ran into a problem in October 2009. It highlighted October 10, 2009. So I added the following to my code:

With Range("C7:AM7")
        .FormatConditions.Delete
        .FormatConditions.Add Type:=xlExpression, Formula1:= _
                              "=month($c$5)<>month(today())"
        .FormatConditions.Add Type:=x1Expression, Formula1:= _
                              "=year($c$5)<>year(today())"        
        .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
                              Formula1:="=day(today())"
        .FormatConditions(2).Interior.ColorIndex = 3
    End With

But then when I type in the Month and year in the InputBox, I get the error message from the on Error GoTo My Error Trap.

So I assume the code I have added the syntax is wrong. Again any suggestions.

Thanks,
jlcford

**royUK** · 10-10-2008, 12:34 PM

I would not use the error trap whilst developing the code. It throws the message whatever error is generated.

I think this does what you want

Sub CalendarMaker()

    ' Unprotect sheet if had previous calendar to prevent error.
    ActiveSheet.Protect DrawingObjects:=False, Contents:=False, _
                        Scenarios:=False
    ' Prevent screen flashing while drawing calendar.
    Application.ScreenUpdating = False
    ' Set up error trapping.
    On Error GoTo MyErrorTrap
    ' Clear area c5:am5 including any previous calendar.
    Range("C5:AM5").Clear
    ' Use InputBox to get desired month and year and set variable
    ' MyInput.
    MyInput = InputBox("Type in Month and year for Calendar ")
    ' Allow user to end macro with Cancel in InputBox.
    If MyInput = "" Then Exit Sub
    ' Get the date value of the beginning of inputted month.
    StartDay = DateValue(MyInput)
    ' Check if valid date but not the first of the month
    ' -- if so, reset StartDay to first day of month.
    If Day(StartDay) <> 1 Then
        StartDay = DateValue(Month(StartDay) & "/1/" & _
                             Year(StartDay))
    End If
    ' Prepare cell for Month and Year as fully spelled out.
    Range("C5").NumberFormat = "mmmm yyyy"
    ' Center the Month and Year label across c5:am5 with appropriate
    ' size, height and bolding.
    With Range("C5:AM5")
        .ColumnWidth = 2.57
        .HorizontalAlignment = xlCenterAcrossSelection
        .VerticalAlignment = xlCenter
        .Font.Size = 18
        .Font.Bold = True
        .RowHeight = 35
    End With

    ' Prepare C7:AM7 for dates with center alignment, size, height
    ' and bolding.
    With Range("C7:AM7")
        .ColumnWidth = 2.57
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Font.Size = 10
        .Font.Bold = True
        .RowHeight = 12.75
    End With
    ' Put inputted month and year fully spelling out into "c5".
    Range("C5").Value = Format(MyInput, "mmmm yyyy")
    ' Set variable and get which day of the week the month starts.
    DayofWeek = Weekday(StartDay)
    ' Set variables to identify the year and month as separate
    ' variables.
    CurYear = Year(StartDay)
    CurMonth = Month(StartDay)
    ' Set variable and calculate the first day of the next month.
    FinalDay = DateSerial(CurYear, CurMonth + 1, 1)
    ' Place c "1" in cell position of the first day of the chosen
    ' month based on DayofWeek.
    Select Case DayofWeek
        Case 1
            Range("C7").Value = 1
        Case 2
            Range("D7").Value = 1
        Case 3
            Range("E7").Value = 1
        Case 4
            Range("F7").Value = 1
        Case 5
            Range("G7").Value = 1
        Case 6
            Range("H7").Value = 1
        Case 7
            Range("I7").Value = 1
    End Select
    ' Loop through range C7:AM7 incrementing each cell after the "1"
    ' cell.
    For Each cell In Range("C7:AM7")
        ColCell = cell.Column
        ' Do if "1" is in first column.
        If cell.Column = 1 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
            ' 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


    With Range("C7:AM7")
       .FormatConditions.Delete
    .FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=Year($C$5)<>year(Today())"
    .FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=month($C$5)<>month(today())"
    .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
                              Formula1:="=day(today())"
    .FormatConditions(3).Interior.ColorIndex = 1
    End With

    ' Turn on gridlines
    ActiveWindow.DisplayGridlines = True
    ' Protect sheet to prevent overwriting the dates.
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, _
                        Scenarios:=True

    ' Prevent going to error trap unless error found by exiting Sub
    ' here.
    Exit Sub
    ' Error causes msgbox to indicate the problem, provides new input box,
    ' and resumes at the line that caused the error.
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

**jlcford** · 10-10-2008, 02:00 PM

Thanks again for your help. I have posted the calendar through December 2009 with no problems.

jlcford

VB Calendar Macro to highlight current date

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

VB Calendar Macro to highlight current date

Problem with highlighting dates preceding years

Calendar with Highlighted Date now completely Functional

Thread Information

Users Browsing this Thread

Similar Threads

create macro to delete row with a date previous to current date

Advanced Timesheet

Don't open the VB Editor when a macro is executed

macro for matching date and changing cell color and merging like cells

Bookmarks

Bookmarks

Posting Permissions