' Calendrier dans une cellule
' Un double-clic sur une cellule de la plage réglée ouvre un petit calendrier du mois à côté
' d'elle. Un clic sur un jour écrit la date dans la cellule et ferme le calendrier, les deux
' flèches changent de mois et la croix le ferme sans rien écrire.
' Le calendrier est fait de formes dont le nom commence par SelecteurDate_, et ce sont les
' seules que la macro efface. Le code ne déclare rien en tête de module : il se colle sous
' celui qu'une autre macro a déjà mis dans la feuille.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
' À MODIFIER : les cellules où un double-clic ouvre le calendrier
Const PLAGE_DATES As String = "C2:C200"
Dim cible As Range
' Une cellule fusionnée peut arriver avec toute sa zone : la date part dans sa première cellule.
Set cible = Target.Cells(1, 1)
If Target.CountLarge > 1 And Target.Address <> cible.MergeArea.Address Then Exit Sub
If Intersect(cible, Me.Range(PLAGE_DATES)) Is Nothing Then Exit Sub
' Sur une feuille protégée, une cellule verrouillée ne recevrait pas la date : Excel garde
' alors son double-clic habituel.
If Me.ProtectContents And cible.Locked Then Exit Sub
' Le double-clic n'entre pas dans la cellule quand le calendrier a pu s'afficher.
If Dessiner(cible, PremierDuMois(cible.Value)) Then Cancel = True
End Sub
' Les trois procédures suivantes répondent aux clics sur le calendrier. Elles lisent le nom de
' la forme cliquée dans Application.Caller, ou dans leur paramètre quand une autre macro les
' lance.
' Un clic sur un jour : la date part dans la cellule, puis le calendrier se ferme.
Public Sub SelecteurDate_Jour(Optional ByVal forme As String)
Dim cible As Range
If forme = "" Then forme = NomDuClic()
If forme = "" Then Exit Sub
On Error GoTo Sortie
Set cible = Me.Names("SelecteurDate_Cible").RefersToRange
Effacer
' Une cellule au format Texte recevrait la date en texte, écrite à l'américaine : elle passe
' au format de date court de Windows.
If cible.NumberFormat = "@" Then cible.NumberFormat = "m/d/yyyy"
' Le nom de la forme porte le numéro de série du jour, SelecteurDate_J46338 pour le 12/11/2026.
cible.Value = CDate(CLng(Mid$(forme, Len("SelecteurDate_J") + 1)))
Exit Sub
Sortie:
' La cellule a disparu (sa ligne a été supprimée) ou refuse la date : on ferme sans écrire.
Effacer
End Sub
' Un clic sur une flèche : le calendrier passe au mois précédent ou au mois suivant.
Public Sub SelecteurDate_Mois(Optional ByVal forme As String)
Dim cible As Range
Dim premier As Date
If forme = "" Then forme = NomDuClic()
If forme = "" Then Exit Sub
On Error GoTo Sortie
Set cible = Me.Names("SelecteurDate_Cible").RefersToRange
premier = CDate(CLng(Me.Shapes("SelecteurDate_Fond").AlternativeText))
If forme = "SelecteurDate_Prec" Then
premier = DateAdd("m", -1, premier)
Else
premier = DateAdd("m", 1, premier)
End If
Dessiner cible, premier
Exit Sub
Sortie:
Effacer
End Sub
' Un clic sur la croix : le calendrier se ferme sans rien écrire.
Public Sub SelecteurDate_Fermer(Optional ByVal forme As String)
Effacer
End Sub
' Dessine le calendrier du mois qui commence le jour « premier », à droite de la cellule.
' Rend False quand la feuille refuse les formes (une feuille protégée avec ses objets).
Private Function Dessiner(ByVal cible As Range, ByVal premier As Date) As Boolean
' La taille d'une case du calendrier, en points.
Const CASE_L As Single = 21
Const CASE_H As Single = 18
Dim zone As Range
Dim visible As Range
Dim forme As Shape
Dim gauche As Single, haut As Single, largeur As Single, hauteur As Single
Dim droite As Single, bas As Single
Dim x As Single, y As Single
Dim jour As Date, choisi As Date
Dim colonne As Long, semaine As Long, i As Long
Dim ecran As Boolean
ecran = Application.ScreenUpdating
Application.ScreenUpdating = False
On Error GoTo Echec
Effacer
Set zone = cible.MergeArea
largeur = 7 * CASE_L + 8
hauteur = 8 * CASE_H + 8
gauche = zone.Left + zone.Width + 2
haut = zone.Top
' Près du bord de la fenêtre, le calendrier passe à gauche de la cellule, ou remonte.
If ActiveSheet Is Me Then
On Error Resume Next
Set visible = ActiveWindow.Panes(ActiveWindow.Panes.Count).VisibleRange
On Error GoTo Echec
End If
If Not visible Is Nothing Then
' La dernière colonne et la dernière ligne visibles peuvent n'être vues qu'en partie :
' le bord de la fenêtre se prend à leur début.
droite = visible.Columns(visible.Columns.Count).Left
bas = visible.Rows(visible.Rows.Count).Top
If gauche + largeur > droite And zone.Left - largeur - 2 >= visible.Left Then
gauche = zone.Left - largeur - 2
End If
If haut + hauteur > bas Then
haut = bas - hauteur
If haut < visible.Top Then haut = visible.Top
End If
End If
' Un nom masqué retient la cellule visée, et la suit si des lignes sont insérées pendant
' que le calendrier est ouvert.
Me.Names.Add Name:="SelecteurDate_Cible", Visible:=False, _
RefersTo:="='" & Replace(Me.Name, "'", "''") & "'!" & cible.Address
' Le fond garde le premier jour du mois affiché, que relisent les flèches.
Set forme = Poser("Fond", gauche, haut, largeur, hauteur, "", "")
forme.Line.Visible = msoTrue
forme.Line.ForeColor.RGB = RGB(166, 166, 166)
forme.AlternativeText = CStr(CLng(premier))
x = gauche + 4
y = haut + 4
Set forme = Poser("Prec", x, y, CASE_L, CASE_H, ChrW(8249), "SelecteurDate_Mois")
forme.TextFrame.Characters.Font.Size = 12
Set forme = Poser("Titre", x + CASE_L, y, 4 * CASE_L, CASE_H, NomDuMois(premier), "")
forme.TextFrame.Characters.Font.Bold = True
Set forme = Poser("Suiv", x + 5 * CASE_L, y, CASE_L, CASE_H, ChrW(8250), "SelecteurDate_Mois")
forme.TextFrame.Characters.Font.Size = 12
Set forme = Poser("Croix", x + 6 * CASE_L, y, CASE_L, CASE_H, ChrW(215), "SelecteurDate_Fermer")
' Les initiales des jours, lundi en tête, dans la langue de Windows (le 1er janvier 2024
' était un lundi).
For i = 0 To 6
Set forme = Poser("E" & (i + 1), x + i * CASE_L, y + CASE_H, CASE_L, CASE_H, _
UCase$(Left$(Format$(DateSerial(2024, 1, 1 + i), "ddd"), 1)), "")
forme.TextFrame.Characters.Font.Color = RGB(128, 128, 128)
Next i
If VarType(cible.Value) = vbDate Then choisi = Int(cible.Value)
jour = premier
semaine = 0
Do While Month(jour) = Month(premier)
colonne = Weekday(jour, vbMonday) - 1
Set forme = Poser("J" & CLng(jour), x + colonne * CASE_L, y + (2 + semaine) * CASE_H, _
CASE_L, CASE_H, CStr(Day(jour)), "SelecteurDate_Jour")
' Le samedi et le dimanche en gris, aujourd'hui encadré, la date de la cellule en vert.
If colonne >= 5 Then forme.TextFrame.Characters.Font.Color = RGB(128, 128, 128)
If jour = Date Then
forme.Line.Visible = msoTrue
forme.Line.ForeColor.RGB = RGB(33, 115, 70)
End If
If jour = choisi Then
forme.Fill.ForeColor.RGB = RGB(33, 115, 70)
forme.TextFrame.Characters.Font.Color = RGB(255, 255, 255)
forme.TextFrame.Characters.Font.Bold = True
End If
If colonne = 6 Then semaine = semaine + 1
jour = jour + 1
Loop
Application.ScreenUpdating = ecran
Dessiner = True
Exit Function
Echec:
Effacer
Application.ScreenUpdating = ecran
Dessiner = False
End Function
' Pose une case du calendrier. Une case qui porte une action lance cette procédure au clic.
Private Function Poser(ByVal nom As String, ByVal gauche As Single, ByVal haut As Single, _
…