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. 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 ("<" and ">" ) 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 = 75
.Top = 1
.Width = 20
.Height = 20
End With
Set Cl = New Classe1
Set Cl.Bouton = Obj
Collect.Add Cl
Set Obj = Me.Controls.Add("forms.CommandButton.1")
With Obj
.Name = "MoisSuiv"
.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.developpez.com/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
