Faciliter la saisie d'une date

Bonjour,

Tout pareil que JoyeuxNoel !

@ bientôt

LouReeD

Hello les amis excellents, JoyeuxNoël & LouReeD

mouais, je me suis mélangé les pseudos ... bon cela arrive quand on joue avec les schmilblicks

Meme si je change les couleurs dans le code, le calendrier reste identique

Curieux, doit y avoir autre chose dans ton fichier ou tes paramètres car chez moi j'ai ces couleurs. Donc là je ne peux pas vraiment t'aider ... je vois d'ailleurs que même la couleur de la colonne F n'est pas la même !!

D'ailleurs, cette couleur marron ressemble bien à une texture, non ?

Bonjour a tous,

Je me permet de revenir car j'ai trouvé la solution à mon problème.

En fait (Je ne sais meme pas pourquoi ni comment), le thème principal était sur une autre couleur que "Office"

Mise en page > Thèmes

Du coup, j'ai bien le même calendrier que Steelson

Merci beaucoup en tout cas

Bonjour @Steelson,

Je me permets de modifier légèrement ton code pour que l’affichage du calendrier se fasse lorsqu’on double-clique sur n’importe quelle cellule, même fusionnée ou bien quand la cellule contient déjà une date :

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    On Error GoTo fin
    Cancel = True
    affichercalendrier
    If Target.Cells(1).NumberFormat = "General" Then Target.Cells(1).NumberFormat = "dd/mm/yyyy"
    Exit Sub
fin:
    fermercalendrier
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 VBA.IsDate(Target.Cells(1)) Then
        fermercalendrier
        Exit Sub
    End If
    affichercalendrier
    Exit Sub
fin:
    fermercalendrier
End Sub

Dans le code de la macro :

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

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    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.Cells(1) = "", Date, MSjour.Cells(1))
    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"
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

J’ai modifié la ligne

If quand = -1 Then quand = IIf(MSjour = "", Date, MSjour)

en

If quand = -1 Then quand = IIf(MSjour.Cells(1) = "", Date, MSjour.Cells(1))

pour éviter que ça déclenche une erreur.

Merci pour cet ensemble de macros que j’apprécie beaucoup !

Merci pour ce retour.

Bonjour et Bravo pour votre code

Un travail de programmation Magnifique et une souplesse d'emploi qui correspond parfaitement à ce que je cherchais.

Un seul obstacle cependant: pour être exécuté dans les cas voulu de saisie de date, il faut nommer la cellule avec "date". Bien que cela solutionne le problème, la contrepartie est de nombreux noms "date......." qui deviennent un peu encombrants.

Compte tenu de vos grandes capacités à trouver la solution de programmation, je pensais à vérifier la situation du format de cellule ? si celui ci est un format date, la sélection de cette cellule enclencherait votre DatePicker et donc plus besoin de nommer toutes les cellules de dates ? qu'en pensez vous

Cordialement Jean Jacques

Plus de Soucis, j'ai trouvé MON erreur MONSTRUEUSE

J'avais mal tapé le mot ".appliction" . J'ai trouvé en passant au debugger en pas à pas. Maintenant c'est super Parfait

Curiosité de ma part, pour quelle raison avez vous inscrit les RGB dans le corp de programme au lieu de l'affecter à des variables qui par ailleurs permettent de facilement les paramétrer ?

Merci quand même , à Steelson et vous même cette appli est superbe