Faciliter la saisie d'une date

Le 20/03/2020 à 13:23

Voici un code qui permettra de saisir une date à l'aide d'un calendrier, ce code est compatible windows et mac (pas de userform, pas d'ActiveX) ...

Dans la feuille où se trouve la date, copier le code suivant :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Intersect(Target, Range("D5")) Is Nothing Then Exit Sub
    Cancel = True
    affichercalendrier
End Sub

en adaptant D5 au besoin.

Puis charger le module suivant :

Option Explicit
Const prefixe = "MSCalend"
Dim MSjour As Range
' mike steelson

Sub affichercalendrier(Optional quand As Date = -1)
Dim Sh As Object, posx%, posy%, i%, j%, tableau() As String
Dim jour As Long, mois As Integer, annee As Integer, moisplus As Long, moismoins As Long

    Set MSjour = Selection

    For Each Sh In ActiveSheet.Shapes
        If Left(Sh.Name, Len(prefixe)) = prefixe Then Sh.Delete
    Next

    posx = MSjour.Offset(0, 1).Left + 4: posy = MSjour.Top + 4
    With ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
        posx, posy, 240, 160)
        .Name = prefixe
        .Visible = True
        .Fill.ForeColor.RGB = RGB(160, 160, 224)
    End With

    If quand = -1 Then quand = IIf(MSjour = "", Date, MSjour)
    quand = DateSerial(Year(quand), Month(quand), 1)
    quand = quand - Weekday(quand, vbMonday) + 1
    mois = Month(quand + 7)
    annee = Year(quand + 7)

            With ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, posx + 8, posy + 8, 32, 20)
                .Name = prefixe & "_Moins"
                .TextFrame.Characters.Text = "<<"
                .TextFrame.HorizontalAlignment = xlHAlignCenter
                .TextFrame.VerticalAlignment = xlVAlignCenter
                .TextFrame.Characters.Font.Color = RGB(240, 0, 0)
                .Fill.ForeColor.RGB = RGB(192, 192, 192)
                moismoins = DateSerial(annee, mois - 1, 1)
                .OnAction = "'affichercalendrier(" & moismoins & ")'"
            End With

            With ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, posx + 8 + 32 * 2, posy + 8, 32 * 3, 20)
                .Name = prefixe & "_Mois"
                .TextFrame.HorizontalAlignment = xlHAlignCenter
                .TextFrame.VerticalAlignment = xlVAlignCenter
                .TextFrame.Characters.Text = Format(DateSerial(annee, mois, 1), "mmm-yyyy")
                .TextFrame.Characters.Font.Color = RGB(240, 0, 0)
                .Fill.ForeColor.RGB = RGB(240, 240, 240)
            End With

            With ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, posx + 8 + 32 * 6, posy + 8, 32, 20)
                .Name = prefixe & "_Plus"
                .TextFrame.HorizontalAlignment = xlHAlignCenter
                .TextFrame.VerticalAlignment = xlVAlignCenter
                .TextFrame.Characters.Text = ">>"
                .TextFrame.Characters.Font.Color = RGB(240, 0, 0)
                .Fill.ForeColor.RGB = RGB(192, 192, 192)
                moisplus = DateSerial(annee, mois + 1, 1)
                .OnAction = "'affichercalendrier(" & moisplus & ")'"
            End With

    For j = 1 To 7
        For i = 1 To 6
            jour = quand + j + 7 * i - 8
            With ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, posx + 8 + 32 * (j - 1), posy + 12 + 20 * i, 32, 20)
                .Name = prefixe & jour
                .TextFrame.HorizontalAlignment = xlHAlignCenter
                .TextFrame.VerticalAlignment = xlVAlignCenter
                .TextFrame.Characters.Text = Day(jour)
                .TextFrame.Characters.Font.Color = IIf(EstJourFerie(jour), RGB(240, 0, 0), IIf(jour = Date, RGB(240, 0, 240), IIf(Weekday(jour, vbMonday) > 5, RGB(0, 0, 240), RGB(0, 0, 0))))
                .Fill.ForeColor.RGB = IIf(Month(jour) = mois, RGB(240, 240, 240), RGB(192, 192, 192))
                .OnAction = "'ChoixDate(" & jour & ")'"
            End With
        Next
    Next

    For Each Sh In ActiveSheet.Shapes
        If Left(Sh.Name, Len(prefixe)) = prefixe Then
            i = i + 1
            ReDim Preserve tableau(1 To i)
            tableau(i) = Sh.Name
        End If
    Next
    If i = 0 Then Exit Sub
    Set Sh = ActiveSheet.Shapes.Range(tableau).Group
    Sh.Name = prefixe & "_Groupe"
    Sh.Shadow.Type = msoShadow21

End Sub

Sub ChoixDate(quand)
Dim Sh As Object
    MSjour.Value = quand
    For Each Sh In ActiveSheet.Shapes
        If Left(Sh.Name, Len(prefixe)) = prefixe Then Sh.Delete
    Next
End Sub
Le 21/03/2020 à 09:25

Evolution pour permettre l'effacement du calendrier sans choisir de date ... j'ai ajouté une case avec une croix X

J'en ai aussi profité pour ajouter la date du jour en sélection avec une case J

capture d ecran 440 
Option Explicit
Const prefixe = "MSCalend"
Dim MSjour As Range
' mike steelson

Sub affichercalendrier(Optional quand As Date = -1)
Dim Sh As Object, posx%, posy%, i%, j%, tableau() As String
Dim jour As Long, mois As Integer, annee As Integer, moisplus As Long, moismoins As Long

    Set MSjour = Selection

    For Each Sh In ActiveSheet.Shapes
        If Left(Sh.Name, Len(prefixe)) = prefixe Then Sh.Delete
    Next

    posx = MSjour.Offset(0, 1).Left + 4: posy = MSjour.Top + 4
    With ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
        posx, posy, 240, 160)
        .Name = prefixe
        .Visible = True
        .Fill.ForeColor.RGB = RGB(160, 160, 224)
    End With

    If quand = -1 Then quand = IIf(MSjour = "", Date, MSjour)
    quand = DateSerial(Year(quand), Month(quand), 1)
    quand = quand - Weekday(quand, vbMonday) + 1
    mois = Month(quand + 7)
    annee = Year(quand + 7)

            With ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, posx + 8, posy + 8, 32, 20)
                .Name = prefixe & "_J"
                .TextFrame.HorizontalAlignment = xlHAlignCenter
                .TextFrame.VerticalAlignment = xlVAlignCenter
                .TextFrame.Characters.Text = "J"
                .TextFrame.Characters.Font.Color = RGB(240, 0, 240)
                .Fill.ForeColor.RGB = RGB(240, 240, 240)
                .OnAction = "'affichercalendrier(" & CLng(Date) & ")'"
            End With

            With ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, posx + 8 + 32, posy + 8, 32, 20)
                .Name = prefixe & "_Moins"
                .TextFrame.Characters.Text = "<<"
                .TextFrame.HorizontalAlignment = xlHAlignCenter
                .TextFrame.VerticalAlignment = xlVAlignCenter
                .TextFrame.Characters.Font.Color = RGB(0, 0, 0)
                .Fill.ForeColor.RGB = RGB(192, 192, 192)
                moismoins = DateSerial(annee, mois - 1, 1)
                .OnAction = "'affichercalendrier(" & moismoins & ")'"
            End With

            With ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, posx + 8 + 32 * 2, posy + 8, 32 * 3, 20)
                .Name = prefixe & "_Mois"
                .TextFrame.HorizontalAlignment = xlHAlignCenter
                .TextFrame.VerticalAlignment = xlVAlignCenter
                .TextFrame.Characters.Text = Format(DateSerial(annee, mois, 1), "mmm-yyyy")
                .TextFrame.Characters.Font.Color = RGB(240, 0, 240)
                .Fill.ForeColor.RGB = RGB(240, 240, 240)
            End With

            With ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, posx + 8 + 32 * 5, posy + 8, 32, 20)
                .Name = prefixe & "_Plus"
                .TextFrame.HorizontalAlignment = xlHAlignCenter
                .TextFrame.VerticalAlignment = xlVAlignCenter
                .TextFrame.Characters.Text = ">>"
                .TextFrame.Characters.Font.Color = RGB(0, 0, 0)
                .Fill.ForeColor.RGB = RGB(192, 192, 192)
                moisplus = DateSerial(annee, mois + 1, 1)
                .OnAction = "'affichercalendrier(" & moisplus & ")'"
            End With

            With ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, posx + 8 + 32 * 6, posy + 8, 32, 20)
                .Name = prefixe & "_X"
                .TextFrame.HorizontalAlignment = xlHAlignCenter
                .TextFrame.VerticalAlignment = xlVAlignCenter
                .TextFrame.Characters.Text = "X"
                .TextFrame.Characters.Font.Color = RGB(240, 0, 0)
                .Fill.ForeColor.RGB = RGB(240, 240, 240)
                .OnAction = "'fermercalendrier'"
            End With

    For j = 1 To 7
        For i = 1 To 6
            jour = quand + j + 7 * i - 8
            With ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, posx + 8 + 32 * (j - 1), posy + 12 + 20 * i, 32, 20)
                .Name = prefixe & jour
                .TextFrame.HorizontalAlignment = xlHAlignCenter
                .TextFrame.VerticalAlignment = xlVAlignCenter
                .TextFrame.Characters.Text = Day(jour)
                .TextFrame.Characters.Font.Color = IIf(EstJourFerie(jour), RGB(240, 0, 0), IIf(jour = Date, RGB(240, 0, 240), IIf(Weekday(jour, vbMonday) > 5, RGB(0, 0, 240), RGB(0, 0, 0))))
                .Fill.ForeColor.RGB = IIf(Month(jour) = mois, RGB(240, 240, 240), RGB(192, 192, 192))
                .OnAction = "'ChoixDate(" & jour & ")'"
            End With
        Next
    Next

    For Each Sh In ActiveSheet.Shapes
        If Left(Sh.Name, Len(prefixe)) = prefixe Then
            i = i + 1
            ReDim Preserve tableau(1 To i)
            tableau(i) = Sh.Name
        End If
    Next
    If i = 0 Then Exit Sub
    Set Sh = ActiveSheet.Shapes.Range(tableau).Group
    Sh.Name = prefixe & "_Groupe"
    Sh.Shadow.Type = msoShadow21

End Sub

Sub ChoixDate(quand)
Dim Sh As Object
    MSjour.Value = quand
    For Each Sh In ActiveSheet.Shapes
        If Left(Sh.Name, Len(prefixe)) = prefixe Then Sh.Delete
    Next
End Sub

Sub fermercalendrier()
Dim Sh As Object
    For Each Sh In ActiveSheet.Shapes
        If Left(Sh.Name, Len(prefixe)) = prefixe Then Sh.Delete
    Next
End Sub

ou

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, Range("D5")) Is Nothing Then Exit Sub
    affichercalendrier
End Sub
Le 21/03/2020 à 09:56

Bonjour Steelson,

Encore bravo pour ce petit calendrier autonome et compatible !

Un effet de zoom est-il possible ? Je pose la question sans avoir regardé si c'était prévu dans le code...

Ce serait juste pour l'avoir en plus petit (donc un "dé zoom" ! )

@ bientôt

LouReeD

Le 21/03/2020 à 10:34

Merci pour vos encouragements à tous, xorsankukai, LouReeD, Papou ...

Mon idée est ici de rester assez sobre et simple au prix d'une certaine rigidité. Et surtout ne pas faire appel aux fonctions propres à windows pour rester exportable quelle que soit la plateforme, mac compris (sans pub car je ne suis pas fana de la marque).

Je vais réfléchir à comment mettre un paramètre de taille, genre S, M, L, XL ...

Pour le moment, je trouve le code encore trop long, je vais le raccourcir un poil !

Je rappelle qu'il existe un datePicker dans le add-in proposé par notre administrateur ... plus joli et configurable.

Le 21/03/2020 à 10:43

C'est dingue ça, de trouver cela trop long !

Perso, si j'avais aussi long pour faire un calendrier autonome...

Bref, j'ai essayé de m'y coller, mais si vous voyez le résultat vous rigoleriez !

L'idée de la taille n'est pas un gros problème, et au niveau sobriété, je suis d'accord avec vous c'est pour quoi j'ai mis en commentaire l'instruction de "l'ombre" car sur mon PC cela faisait "clignoter" les shapes... Et oui mon PC date de 2013 donc cette mise "en forme" était de trop pour un affichage instantané et sans clignotement car répétitif dès un changement de choix de date.

Comme vous disiez sur un autre fil, vous êtes (pour le moment) loin du nombre de mes applications, mais les vôtres sont d'un autre acabit ! Je les ADORES ! Bon j'avoue, certaines je ne comprends pas (JSON), mais elles sont exportables et autonomes pour la pluparts (le menu, le calendrier, les listes de choix en cascades "sans limites" du nombre et de la position !...)

Bref, un grand OUI d'encouragement et en plus un accès aux codes ! Franchement, je ne dis qu'une chose : J'achète !!!!

@ bientôt

LouReeD

Le 21/03/2020 à 16:24

Quelques évolutions qui prennent en compte vos remarques :

  • réduction légère de la taille
  • mise en place des jours lundi, mardi etc.
  • réduction de la taille du code (peut-être au détriment de la lisibilité)

Vous pouvez bien sûr adapter selon vos souhaits ...

Option Explicit
Const prefixe = "MSCalend"
Dim MSjour As Range
' mike steelson

Sub affichercalendrier(Optional quand As Date = -1)
Dim Sh As Object, posx%, posy%, i%, j%, tableau() As String
Dim jour As Long, mois As Integer, annee As Integer, moisplus As Long, moismoins As Long

    If MSjour Is Nothing Then Set MSjour = Selection

    For Each Sh In ActiveSheet.Shapes
        If Left(Sh.Name, Len(prefixe)) = prefixe Then Sh.Delete
    Next

    posx = MSjour.Offset(0, 1).Left + 2: posy = MSjour.Top + 2
    With ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
        posx, posy, 208, 144)
        .Name = prefixe
        .Visible = True
        .Fill.ForeColor.RGB = RGB(192, 192, 240)
    End With

    If quand = -1 Then quand = IIf(MSjour = "", Date, MSjour)
    quand = DateSerial(Year(quand), Month(quand), 1)
    quand = quand - Weekday(quand, vbMonday) + 1
    mois = Month(quand + 7)
    annee = Year(quand + 7)
    moismoins = DateSerial(annee, mois - 1, 1)
    moisplus = DateSerial(annee, mois + 1, 1)

    dessiner posx + 6 + 1, posy + 6, 28 - 2, 16, "_J", "J", RGB(240, 0, 240), RGB(240, 240, 240), "'affichercalendrier(" & CLng(Date) & ")'"
    dessiner posx + 6 + 1 + 28, posy + 6, 28 - 2, 16, "_Moins", "<<", RGB(0, 0, 0), RGB(192, 192, 192), "'affichercalendrier(" & moismoins & ")'"
    dessiner posx + 6 + 1 + 28 * 2, posy + 6, 28 * 3 - 2, 16, "_Mois", Format(DateSerial(annee, mois, 1), "mmm-yyyy"), RGB(240, 0, 240), RGB(240, 240, 240), "'MsgBox ""Mike Steelson""'"
    dessiner posx + 6 + 1 + 28 * 5, posy + 6, 28 - 2, 16, "_Plus", ">>", RGB(0, 0, 0), RGB(192, 192, 192), "'affichercalendrier(" & moisplus & ")'"
    dessiner posx + 6 + 1 + 28 * 6, posy + 6, 28 - 2, 16, "_X", "X", RGB(240, 0, 0), RGB(240, 240, 240), "'fermercalendrier'"
    For j = 1 To 7
        dessiner posx + 6 + 28 * (j - 1), posy + 10 + 16, 28, 16, "_J" & j, Format(j + 1, "ddd") & j, RGB(128, 128, 128), RGB(192, 192, 240), "", False
        For i = 1 To 6
            jour = quand + j + 7 * i - 8
            dessiner posx + 6 + 28 * (j - 1), posy + 10 + 16 * (i + 1), 28, 16, _
                CStr(jour), _
                Day(jour), _
                IIf(EstJourFerie(jour), RGB(240, 0, 0), IIf(jour = Date, RGB(240, 0, 240), IIf(Weekday(jour, vbMonday) > 5, RGB(0, 0, 240), RGB(0, 0, 0)))), _
                IIf(Month(jour) = mois, RGB(240, 240, 240), RGB(192, 192, 192)), _
                "'ChoixDate(" & jour & ")'"
        Next
    Next

    For Each Sh In ActiveSheet.Shapes
        If Left(Sh.Name, Len(prefixe)) = prefixe Then
            i = i + 1
            ReDim Preserve tableau(1 To i)
            tableau(i) = Sh.Name
        End If
    Next
    If i = 0 Then Exit Sub
    Set Sh = ActiveSheet.Shapes.Range(tableau).Group
    Sh.Name = prefixe & "_Groupe"

End Sub

Sub dessiner(x%, y%, l%, h%, nom$, texte$, police As Long, fond As Long, action$, Optional ligne = True)
    With ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, x, y, l, h)
        .Name = prefixe & nom
        .TextFrame.HorizontalAlignment = xlHAlignCenter
        .TextFrame.VerticalAlignment = xlVAlignCenter
        .TextFrame.Characters.Text = texte
        .TextFrame.Characters.Font.Size = 9
        .Fill.ForeColor.RGB = fond
        .TextFrame.Characters.Font.Color = police
        .OnAction = action
        .Line.Visible = ligne
    End With
End Sub

Sub ChoixDate(quand)
On Error Resume Next ' cas où le calendrier est resté actif à la fermeture
Dim Sh As Object
    MSjour.Value = quand
    Set MSjour = Nothing
    For Each Sh In ActiveSheet.Shapes
        If Left(Sh.Name, Len(prefixe)) = prefixe Then Sh.Delete
    Next
End Sub

Sub fermercalendrier()
Dim Sh As Object
    Set MSjour = Nothing
    For Each Sh In ActiveSheet.Shapes
        If Left(Sh.Name, Len(prefixe)) = prefixe Then Sh.Delete
    Next
End Sub

'===========partie importée=======================
Le 21/03/2020 à 16:43

Et bien bravo ! Une fois de plus

Mais vous pouviez laisser l'ombre, c'était joli, perso je l'avais enlever pour une question de rapidité, mais sinon c'était très bien !

@ bientôt

LouReeD

Le 27/03/2020 à 05:57

Bonjour,

en réponse à une question, voici comment activer le popup calendrier sur plusieurs cellules d'une même feuille :

exemple des cellules D5 et G9 ...

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Intersect(Target, Range("D5")) Is Nothing And Intersect(Target, Range("G9")) Is Nothing Then Exit Sub
    Cancel = True
    affichercalendrier
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Intersect(Target, Range("D5")) Is Nothing And Intersect(Target, Range("G9")) Is Nothing Then Exit Sub
    affichercalendrier
End Sub

Le code qui génère le calendrier ne change pas.

77saisie-date-sur-calendrier.xlsm (34.04 Ko)
Le 27/03/2020 à 06:58

Bonjour,

ou bien sous Excel créer un Nom, par exemple Cel_Date qui fait référence à toutes ces cellules !

comme cela il suffit de faire

If Intersect(Target,Range("Cel_Date")) Is Nothing Then Exit Sub

Ce qui évite les tests "à rallonge", non ?

@ bientôt

LouReeD

Le 21/06/2020 à 12:05

bonjour,

tout d 'abord merci pour toutes ces indications et amélioration sur votre application, néanmoins je me trouve confronté a un problème concernant le code pour la saisie de date de plusieurs cellules, j ai essayé de mon coté avec le peu de connaissance que je possède et sans succès, donc voilà mon soucis, comment faire pour qu il puisse fonctionner sur une ou plusieurs feuilles précise

merci pour votre réponse

Le 21/06/2020 à 13:05

Bonjour et

Merci pour cette remarque qui fera évoluer cet outil.

La macro est cette fois-ci à mettre dans Thisworkbook

capture d ecran 682 
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    On Error GoTo fin
    If Not Target.Name.Name Like "date*" Then Exit Sub
    Cancel = True
    affichercalendrier
fin:
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    On Error GoTo fin
    If Not Target.Name.Name Like "date*" Then Exit Sub
    affichercalendrier
fin:
End Sub

Toutes les cellules de toutes les feuilles dont le nom commence par date activeront le calendrier. Ce qui rejoint du reste la remarque de LouReeD

59saisie-date-sur-calendrier.xlsm (32.79 Ko)
Le 21/06/2020 à 17:17

re bonjour,

tout d'abord je tien à vous remercier pour avoir pris en compte ma demande au sujet de votre appli que j ai essayé dés votre réponse, cependant je suis confronté à une autre problème car les cellules sur lesquelles je voudrais la faire fonctionner sont fusionner et je ne peut pas modifier leurs aspects, je reviens donc vers vous pour savoir si il y a une solution a ce problème, je vous remercie d'avance pour votre réponse

à bientôt.

Le 21/06/2020 à 17:20

Désolé, mais je ne travaille jamais avec des cellules fusionnées.

Il vaut mieux faire "centrer sur plusieurs colonnes".

Je vais quand même tester pourquoi cela ne fonctionnerait pas avec des cellules fusionnées.

Le 21/06/2020 à 17:27

Effectivement, cela ne fonctionne pas.

J'ai tenté une modification mais cela ne fonctionne pas.

Évite de fusionner.

Partout où tu as une date, dé-fusionne et fais ensuite centrer sur plusieurs colonnes.

Il faudra toujours sélectionner la cellule la plus à gauche de la plage.

La fusion des cellules doit être réservée aux titres, jamais pour les données.

Le 21/06/2020 à 17:31

ok merci je prent note de ton conseil, je vais me débrouiller avec, en tous les cas merci encore,

à bientôt.

Le 21/06/2020 à 18:00

Bonsoir,

Avez-vous votre fichier ? A moins qu'il ne soit "top secret" ?

@ bientôt

LouReeD

Le 21/06/2020 à 18:16

non pas forcement top secret, mais le fichier par lui même et plutôt lourd dans son ensemble, par contre ce que je peut faire une capture d' écran et montrer sur quel cellule je bloque

Le 21/06/2020 à 18:52

Non pas une capture d'écran, le code VBA n'a pas d'influence dessus !

Faites un clic droit sur l'onglet puis déplacer/copier la feuille puis créer une copie dans un nouveau classeur.

sans titre

Et sinon faite comme Steelson a dit : dé fu sio nez...

@ bientôt

LouReeD

Le 21/06/2020 à 19:03

Bonsoir, OK j essayerai de voir pour vous l envoyer, mais plutôt dans le courant de la semaine, je ne suis plus dessus

Merci bonne soirée

Le 21/06/2020 à 21:30

Bon ok, j'ai trouvé la solution pour les inconditionnels des cellules fusionnées !

J'ai ajouté Cells(1,1) à la selection

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    On Error GoTo fin
    If Not Target.Cells(1, 1).Name.Name Like "date*" Then Exit Sub
    Cancel = True
    affichercalendrier
fin:
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    On Error GoTo fin
    If Not Target.Cells(1, 1).Name.Name Like "date*" Then Exit Sub
    affichercalendrier
fin:
End Sub
Option Explicit
Const prefixe = "MSCalend"
Dim MSjour As Range
' mike steelson

Sub affichercalendrier(Optional quand As Date = -1)
Dim Sh As Object, posx%, posy%, i%, j%, tableau() As String
Dim jour As Long, mois As Integer, annee As Integer, moisplus As Long, moismoins As Long

    If MSjour Is Nothing Then Set MSjour = Selection.Cells(1, 1)

    For Each Sh In ActiveSheet.Shapes
        If Left(Sh.Name, Len(prefixe)) = prefixe Then Sh.Delete
    Next

    posx = MSjour.Offset(0, 1).Left + 2: posy = MSjour.Top + 2
    With ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
        posx, posy, 208, 144)
        .Name = prefixe
        .Visible = True
        .Fill.ForeColor.RGB = RGB(192, 192, 240)
    End With

    If quand = -1 Then quand = IIf(MSjour = "", Date, MSjour)
    quand = DateSerial(Year(quand), Month(quand), 1)
    quand = quand - Weekday(quand, vbMonday) + 1
    mois = Month(quand + 7)
    annee = Year(quand + 7)
    moismoins = DateSerial(annee, mois - 1, 1)
    moisplus = DateSerial(annee, mois + 1, 1)

    dessiner posx + 6 + 1, posy + 6, 28 - 2, 16, "_J", "J", RGB(240, 0, 240), RGB(240, 240, 240), "'affichercalendrier(" & CLng(Date) & ")'"
    dessiner posx + 6 + 1 + 28, posy + 6, 28 - 2, 16, "_Moins", "<<", RGB(0, 0, 0), RGB(192, 192, 192), "'affichercalendrier(" & moismoins & ")'"
    dessiner posx + 6 + 1 + 28 * 2, posy + 6, 28 * 3 - 2, 16, "_Mois", Format(DateSerial(annee, mois, 1), "mmm-yyyy"), RGB(240, 0, 240), RGB(240, 240, 240), "'MsgBox ""Mike Steelson""'"
    dessiner posx + 6 + 1 + 28 * 5, posy + 6, 28 - 2, 16, "_Plus", ">>", RGB(0, 0, 0), RGB(192, 192, 192), "'affichercalendrier(" & moisplus & ")'"
    dessiner posx + 6 + 1 + 28 * 6, posy + 6, 28 - 2, 16, "_X", "X", RGB(240, 0, 0), RGB(240, 240, 240), "'fermercalendrier'"
    For j = 1 To 7
        dessiner posx + 6 + 28 * (j - 1), posy + 10 + 16, 28, 16, "_J" & j, Format(j + 1, "ddd") & j, RGB(128, 128, 128), RGB(192, 192, 240), "", False
        For i = 1 To 6
            jour = quand + j + 7 * i - 8
            dessiner posx + 6 + 28 * (j - 1), posy + 10 + 16 * (i + 1), 28, 16, _
                CStr(jour), _
                Day(jour), _
                IIf(EstJourFerie(jour), RGB(240, 0, 0), IIf(jour = Date, RGB(240, 0, 240), IIf(Weekday(jour, vbMonday) > 5, RGB(0, 0, 240), RGB(0, 0, 0)))), _
                IIf(Month(jour) = mois, RGB(240, 240, 240), RGB(192, 192, 192)), _
                "'ChoixDate(" & jour & ")'"
        Next
    Next

    For Each Sh In ActiveSheet.Shapes
        If Left(Sh.Name, Len(prefixe)) = prefixe Then
            i = i + 1
            ReDim Preserve tableau(1 To i)
            tableau(i) = Sh.Name
        End If
    Next
    If i = 0 Then Exit Sub
    Set Sh = ActiveSheet.Shapes.Range(tableau).Group
    Sh.Name = prefixe & "_Groupe"

End Sub

Sub dessiner(x%, y%, l%, h%, nom$, texte$, police As Long, fond As Long, action$, Optional ligne = True)
    With ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, x, y, l, h)
        .Name = prefixe & nom
        .TextFrame.HorizontalAlignment = xlHAlignCenter
        .TextFrame.VerticalAlignment = xlVAlignCenter
        .TextFrame.Characters.Text = texte
        .TextFrame.Characters.Font.Size = 9
        .Fill.ForeColor.RGB = fond
        .TextFrame.Characters.Font.Color = police
        .OnAction = action
        .Line.Visible = ligne
    End With
End Sub

Sub ChoixDate(quand)
On Error Resume Next ' cas où le calendrier est resté actif à la fermeture
Dim Sh As Object
    MSjour.Value = quand
    Set MSjour = Nothing
    For Each Sh In ActiveSheet.Shapes
        If Left(Sh.Name, Len(prefixe)) = prefixe Then Sh.Delete
    Next
End Sub

Sub fermercalendrier()
Dim Sh As Object
    Set MSjour = Nothing
    For Each Sh In ActiveSheet.Shapes
        If Left(Sh.Name, Len(prefixe)) = prefixe Then Sh.Delete
    Next
End Sub

'===========partie importée=======================
Rechercher des sujets similaires à "faciliter saisie date"