Calendar Control for VBA Excel

The calendar control of VBA has changed between Excel 2003 and Excel 2010. The older versions have a control named as "Calendar" and for the new versions it is called the "DT Picker"control.

Are there Compatibility Issues?

Compatibility issues may arise when you try to use:

workbooks with the Calendar control on the new versions of Excel

workbooks with DT Picker on the previous version of Excel.

Another concern lies in the version of Microsoft Office being used. Some corporate configurations do not allow access to the DT Picker control. To remedy this, I suggest that you create your own calendar control, using a Userform.

The UserForm

The UserForm will contain:

29 and 31 command buttons for the "Days".

A label "Choice of the Month".

2 buttons ("" ) to navigate between the months.

The current month and year will be displayed in the "Caption" (title) of the UserForm.

All controls within this UserForm will be created dynamically.

Getting Started

Open your VBA editor, create a new UserForm and change its Name property to "Calendrier".

Copy the below code in the Module of the UserForm:

Option Explicit Private Sub UserForm_Initialize() Dim Obj As Control Dim i As Integer, Mois As Integer, Annee As Integer Dim Cl As Classe1 'Création Changement de mois 'LABEL Set Collect = New Collection Set Obj = Me.Controls.Add("forms.Label.1") With Obj .Name = "LbChoixMois" .Object.Caption = "Choix du mois : " .Left = 5 .Top = 5 .Width = 70 .Height = 10 End With 'BOUTONS < et > Set Obj = Me.Controls.Add("forms.CommandButton.1") With Obj .Name = "MoisPrec" .Object.Caption = "" .Left = 95 .Top = 1 .Width = 20 .Height = 20 End With Set Cl = New Classe1 Set Cl.Bouton = Obj Collect.Add Cl 'Création entête Jours de la semaine For i = 1 To 7 Set Obj = Me.Controls.Add("forms.Label.1") With Obj .Name = "Jour" & i .Object.Caption = UCase(Left(Format(DateSerial(2014, 9, i), "dddd"), 1)) .Left = 20 * (i - 1) + 5 .Top = 25 .Width = 20 .Height = 10 End With Next i 'création boutons "jours" Mois = Month(Date) MoisEnCours = Mois Annee = Year(Date) AnneeEnCours = Annee CreationBoutonsJours Mois, Annee If Left(Format(Date, "dd"), 1) = "0" Then Me.Controls("Bouton" & Format(Date, "d")).SetFocus Else Me.Controls("Bouton" & Format(Date, "dd")).SetFocus End Sub

Create the buttons

The number of days vary from one month to another, so we will create them dynamically. For this, a procedure that we need:

Remove the old buttons

Create new buttons based on the month and year.

Create a module (Insert > Module) and copy the below code:

Option Explicit Public WithEvents Bouton As MSForms.CommandButton Private Sub Bouton_Click() Select Case Bouton.Name Case "MoisPrec" MoisEnCours = MoisEnCours - 1 If MoisEnCours = 0 Then MoisEnCours = 12 AnneeEnCours = AnneeEnCours - 1 If AnneeEnCours = 1899 Then MoisEnCours = 1 AnneeEnCours = 1900 MsgBox "Première année : 1900" End If End If Case "MoisSuiv" MoisEnCours = MoisEnCours + 1 If MoisEnCours = 13 Then MoisEnCours = 1 AnneeEnCours = AnneeEnCours + 1 End If End Select CreationBoutonsJours MoisEnCours, AnneeEnCours End Sub

The Class Modules

We will need to create to class module for the command buttons to work.

To navigate between months:

Option Explicit Public WithEvents Btn As MSForms.CommandButton 'Procédure lors du clic sur un bouton "jour" Private Sub Btn_Click() Dim maDate As Date maDate = CDate(Btn.Caption & "/" & Calendrier.Tag) 'La ligne suivante détermine l'action à effectuer lors d'un clic sur le bouton 'Pour entrer la date choisie dans une cellule et fermer l'Userform : 'ActiveCell.Value = maDate 'Unload Calendrier MsgBox maDate End Sub 'Affiche le nom du jour férié au survol du bouton par la souris Private Sub Btn_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) Dim maDate As Date maDate = CDate(Btn.Caption & "/" & Calendrier.Tag) If EstJourFerie(maDate) Or Paques(Year(maDate)) = maDate Then Btn.ControlTipText = QuelFerie(maDate) End Sub

The class module for the days

Option Explicit Public WithEvents Btn As MSForms.CommandButton 'Procédure lors du clic sur un bouton "jour" Private Sub Btn_Click() Dim maDate As Date maDate = CDate(Btn.Caption & "/" & Calendrier.Tag) 'La ligne suivante détermine l'action à effectuer lors d'un clic sur le bouton 'Pour entrer la date choisie dans une cellule et fermer l'Userform : 'ActiveCell.Value = maDate 'Unload Calendrier MsgBox maDate End Sub 'Affiche le nom du jour férié au survol du bouton par la souris Private Sub Btn_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) Dim maDate As Date maDate = CDate(Btn.Caption & "/" & Calendrier.Tag) If EstJourFerie(maDate) Or Paques(Year(maDate)) = maDate Then Btn.ControlTipText = QuelFerie(maDate) End Sub

Managing public holidays

In the standard module created earlier, we will add three functions to identify holidays.

A function that returns the holiday as a string

'Fonction qui retourne le jour férié en "String" 'utile pour les info-bulles au survol des jours fériés Public Function QuelFerie(Jour As Date) As String Dim maDate As Date Dim a As Integer, m As Integer, j As Integer maDate = Paques(Year(Jour)) If Jour = maDate Then QuelFerie = "Dimanche de Pâques": Exit Function If Jour = CDate(maDate + 1) Then QuelFerie = "Lundi de Pâques": Exit Function If Jour = CDate(maDate + 50) Then QuelFerie = "Lundi de Pentecôte": Exit Function If Jour = CDate(maDate + 39) Then QuelFerie = "Jeudi de l'ascension": Exit Function a = Year(Jour): m = Month(Jour): j = Day(Jour) Select Case m * 100 + j Case 101 QuelFerie = "1er Janvier": Exit Function Case 501 QuelFerie = "1er Mai": Exit Function Case 508 QuelFerie = "8 Mai": Exit Function Case 714 QuelFerie = "14 Juillet": Exit Function Case 815 QuelFerie = "15 Août": Exit Function Case 1101 QuelFerie = "1er Novembre": Exit Function Case 1111 QuelFerie = "11 Novembre": Exit Function Case 1225 QuelFerie = "Noël": Exit Function End Select End Function

A function that identifies the public holidays

'SOURCES : 'http://blog.developpeom/philben/p11458/vba-access/sagit-il-dun-jour-ferie Public Function EstJourFerie(ByVal laDate As Date, Optional ByVal EstPentecoteFerie As Boolean = True) As Boolean 'Détermine si la date passée en argument est un jour férié (en France) ou non : ' 101 = 1er Janvier - 501 = 1er Mai - 508 = 8 Mai - 714 = 14 Juillet ' 815 = 15 Août - 1101 = 1er Novembre - 1111 = 11 Novembre - 1225 = 25 Décembre ' dPa = Lundi de Pâques - dAs = Jeudi de l'Ascension - dPe = Lundi de Pentecôte 'Remarque : Le lundi de Pentecôte est un jour férié mais parfois non chômé (EstPentecoteFerie = False dans ce cas) 'Philben - v1.0 - 2012 - Free to use Static Annee As Integer, dPa As Date, dAs As Date, dPe As Date, bPe As Boolean Dim a As Integer, m As Integer, j As Integer a = Year(laDate): m = Month(laDate): j = Day(laDate) Select Case m * 100 + j Case 101, 501, 508, 714, 815, 1101, 1111, 1225 EstJourFerie = True Case 323 To 614 '323: Date mini Lundi de Pâques - 614 : Date maxi Lundi de Pentecôte If a <> Annee Or EstPentecoteFerie <> bPe Then Annee = a: dPa = Paques(a) + 1: dAs = dPa + 38 bPe = EstPentecoteFerie: If bPe Then dPe = dPa + 49 Else dPe = #1/1/100# End If Select Case DateSerial(a, m, j): Case dPa, dAs, dPe: EstJourFerie = True: End Select End Select End Function