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 !