Faciliter la saisie d'une date

Vous ne lâchez rien Steelson !

Bravo à vous !

@ bientôt

LouReeD

Et en plus je transgresse mes interdits (cellules fusionnées contenant des données)

Vous avez le bon avatar alors :" bon sang, qu'est ce que je suis en train de faire ?"

@ bientôt

LouReeD

bonjour et merci encore pour votre implication, j ai récupéré les codes et je tacherai de voir si je peux l adapter sur mon projet, je vous tiendrais informé des avancées en attendant encore merci

bonjour Steelson, donc ça y est j' ai pu mettre en place le code que vous avez modifié, cela fonctionne plutôt bien le seul bémol c est que dés que je clique sur une cellule concernée cela met un peu de temps pour afficher le calendrier, je pense que c est du fait que j ai pas mal de macros en place, mais sinon plutôt cool et je fait avec, en tout cas je tenait a remercier pour avoir pris le temps de modifier le code

@bientôt

Merci pour ce retour

A noter que la partie importée qui déterminait les jours fériés comportait une erreur. J'ai donc opté pour un autre code que cette fois-ci j'ai entièrement vérifié.

Option Explicit
Const prefixe = "MSCalend"

Dim MSjour As Range
' mike steelson

Sub affichercalendrier(Optional quand As Date = -1)

' couleurs
Dim fondJour, fond, police, policeSemaine, policeWE, policeFerie, fondAujourdhui, policeFermeture, fondAutreMois

' paramètres couleur =============
fond = RGB(168, 192, 240)
fondJour = RGB(240, 240, 240)
fondAujourdhui = RGB(240, 240, 0)
fondAutreMois = RGB(192, 192, 192)

police = RGB(0, 0, 0)
policeSemaine = RGB(128, 128, 128)
policeWE = RGB(0, 0, 240)
policeFerie = RGB(240, 0, 0)
policeFermeture = RGB(240, 0, 0)
' ================================

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 = fond
    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, "_M", "M", police, fondAujourdhui, "'affichercalendrier(" & CLng(Date) & ")'"
    dessiner posx + 6 + 1 + 28, posy + 6, 28 - 2, 16, "_Moins", "<<", police, fondAutreMois, "'affichercalendrier(" & moismoins & ")'"
    dessiner posx + 6 + 1 + 28 * 2, posy + 6, 28 * 3 - 2, 16, "_Mois", Format(DateSerial(annee, mois, 1), "mmm-yyyy"), police, fondJour, "'MsgBox ""Mike Steelson""'"
    dessiner posx + 6 + 1 + 28 * 5, posy + 6, 28 - 2, 16, "_Plus", ">>", police, fondAutreMois, "'affichercalendrier(" & moisplus & ")'"
    dessiner posx + 6 + 1 + 28 * 6, posy + 6, 28 - 2, 16, "_X", "X", policeFermeture, fondJour, "'fermercalendrier'"
    For j = 1 To 7
        dessiner posx + 6 + 28 * (j - 1), posy + 10 + 16, 28, 16, "_J" & j, Format(j + 1, "ddd") & j, policeSemaine, fond, "", 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(IsFerie(jour), policeFerie, IIf(Weekday(jour, vbMonday) > 5, policeWE, police)), _
                IIf(Month(jour) <> mois, fondAutreMois, IIf(jour = Date, fondAujourdhui, fondJour)), _
                "'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$, ByVal police As Long, ByVal 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=======================

' https://www.3stone.be/access5/articles.php?lng=fr&pg=106&tconfig=0
Function IsFerie(jour As Variant) As Boolean
    'd'après Ole P Erlandsen
    Dim ListeFeries(1 To 11) As Long, i As Integer
    Dim tDate As Long, annee As Integer

    IsFerie = False
    tDate = CDate(jour)

    If tDate < 1 Then Exit Function
    annee = Year(tDate)
    If annee < 1900 Then Exit Function

    'remplit la liste des fériés
    ListeFeries(1) = CDate("1/1/" & annee)    'Jour de l'An
    ListeFeries(2) = fnPaques(annee) + 1      'Lundi de Pâques
    ListeFeries(3) = ListeFeries(2) + 38      'Jeudi Ascension
    ListeFeries(4) = ListeFeries(2) + 49      'Lundi Pentecôte
    ListeFeries(5) = CDate("1/5/" & annee)    '1er Mai
    ListeFeries(6) = CDate("8/5/" & annee)    '8 Mai
    ListeFeries(7) = CDate("14/7/" & annee)   '14 Juillet
    ListeFeries(8) = CDate("15/8/" & annee)   '15 Août
    ListeFeries(9) = CDate("1/11/" & annee)   'Toussaint
    ListeFeries(10) = CDate("11/11/" & annee) '14-18
    ListeFeries(11) = CDate("25/12/" & annee) 'Noël

    ' compare la date entrée avec la Liste des Fériés
    i = 1
    While i <= UBound(ListeFeries) And IsFerie = False
        If tDate = ListeFeries(i) Then IsFerie = True
        i = i + 1
    Wend

    ' ajout pour inclure Pâques dans les jours fériés
    If tDate = fnPaques(Year(tDate)) Then IsFerie = True

End Function
Public Function fnPaques(wAn%) As Date
    'Pâques est le dimanche qui suit le quatorzième jour de la
    'Lune qui tombe le 21 mars ou immédiatement après

    Dim wA%, wb%, wC%, wD%, wE%, wF%, wG%, wH%
    Dim wI%, wJ%, wK%, wL%, wM%, wN%, wP%

    wA = wAn Mod 19    'Calcul du rang de l'année dans le cycle lunaire qui a 19 ans
    wb = wAn \ 100     'Calcul du siècle
    wC = wAn Mod 100   'Calcul du rang de l'année dans le siècle
    wD = wb \ 4
    wE = wb Mod 4
    wF = (wb + 8) \ 25
    wG = (wb - wF + 1) \ 3
    wH = (19 * wA + wb - wD - wG + 15) Mod 30
    wI = wC \ 4
    wK = wC Mod 4
    wL = (32 + 2 * wE + 2 * wI - wH - wK) Mod 7
    wM = (wA + 11 * wH + 22 * wL) \ 451
    wN = (wH + wL - 7 * wM + 114) \ 31      'détermine le mois
    wP = (wH + wL - 7 * wM + 114) Mod 31    'détermine le jour
    fnPaques = DateSerial(wAn, wN, wP + 1)

End Function

Ça fonctionne parfaitement de mon côté, merci beaucoup pour le partage ! :D

Bonjour,

Je relance un peu le post.

Je suis très intéressé par cette solution, par contre j'ai quelques soucis avec l'intégration.

En effet, la cellule ou je souhaite activer le calendrier est une cellule fusionné, sur une feuille en particulier.

Le soucis, est que quand je click sur la cellule en question, soit il ne se passe rien, soit une affiche une image marron .

J'ai pourtant essayer les différents codes, mais rien n'y fait .

Bonjour,

pourrais tu mettre une copie simplifiée de ton fichier avec cette fameuse cellule fusionnée et les codes que tu as copiés ?

merci

C'est compliqué pour moi de mettre le fichier, car beaucoup de chose a modifier pour le simplifier.

En gros mes cellules fusionnées sont H6 à K6, d'une feuille nommé "DEVIS HT"

Et en fait j'ai essayé tous tes codes.

Que ce soit ceux du fichier joint, ou ceux sur le forum

rafu59 a écrit :

C'est compliqué pour moi de mettre le fichier, car beaucoup de chose a modifier pour le simplifier.

ben il suffirait de mettre une feuille et le code !!

donc je l'ai fait ...

Alors quand je copie le code dans ThisWorkbook, rien ne se passe.

Et quand je le colle dans le feuille "DEVIS HT", j'ai une erreur de compilation

1- d'où l'intérêt de mettre un fichier simplifié !

2- est-ce que le fichier tel quel fonctionne ?

3- tu as 2 sub du même nom "Workseet_Selectionchange" ... ce n'est pas possible. Supprime la première pour commencer et regarde si ok. Ensuite explique ce que tu veux faire avec cette première sub qui va fatalement te créer seule (indépendamment de la date) des problèmes car tu risques d'en créer2 avec le même nom.

Re,

Mon fichier fonctionne.

Ton Fichier fonctionne correctement tout seul.

Mais des que j'intègre le code dans mon fichier, soit ca plante, soit j'ai un calendrier "écrasé" ou marron.

Les 2 sub "Worksheet_Selectionchange", sont en fait pour bloquer le nom des onglets

Compte tenu de ta mise en page, change cette partie de code comme suit :

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

Essaie de "cumuler" les 2 fonctions

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If ActiveSheet.Name <> "DEVIS HT" Then ActiveSheet.Name = "DEVIS HT"
On Error Resume Next ' en cas de sélection complète de la feuille
    If Intersect(Target, Range("H6")) Is Nothing Then Exit Sub
    'If Target.Count > 1 Then Exit Sub
    affichercalendrier
End Sub

j'en conclus au passage que tu n'as toujours qu'une seule feuille.

Merci, le calendrier s'affiche désormais.

Il en reste que les couleurs ne sont pas les meme que dans le classeur de Steelson.

Et, non j'ai plusieurs feuilles, mais je n'ai besoin de saisir la date qu'une seule fois.

rafu59 a écrit :

Et, non j'ai plusieurs feuilles, mais je n'ai besoin de saisir la date qu'une seule fois.

ce que je voulais dire, c'est que si tu as plusieurs feuilles, et même si tu ne saisis la date que sur une seule feuille, ta macro

If ActiveSheet.Name <> "DEVIS HT" Then ActiveSheet.Name = "DEVIS HT"

tentera mettre le même nom "DEVIS HT" sur toutes les feuilles, et là ça va coincer.

Pour moi, ce genre d'instruction est à réserver aux fichiers à feuille unique donc.

Bonjour,

les couleurs sont ici ... tu peux les modifier à ta convenance

' paramètres couleur =============
fond = RGB(168, 192, 240)
fondJour = RGB(240, 240, 240)
fondAujourdhui = RGB(240, 240, 0)
fondAutreMois = RGB(192, 192, 192)

police = RGB(0, 0, 0)
policeSemaine = RGB(128, 128, 128)
policeWE = RGB(0, 0, 240)
policeFerie = RGB(240, 0, 0)
policeFermeture = RGB(240, 0, 0)
' ================================

Bonjour,

Ah bah voilà, c'est quand même mieux quand Steelson prend le relai.

Non mais c'est qui ce стаrnebny qui arrive comme un cheveu sur la soupe ? 😁

(désolé pour l'interruption dans vos échanges, je ne faisais que passer)