Microsoft 365 Calendrier : Modifier Target > change R

[Usine à gaz]

Re à toutes et à tous,

J'essaie de modifier le Calendrier de mon cher RolandM que je ne vois plus depuis un bon moment sur le Forum et que je n'arrive pas à joindre au téléphone pour prendre de ses nouvelles (je suis très inquiet pour lui).
son code est le suivant :

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
If Hour(Now) < 8 Then
'If [a1] < 8 Then
MsgBox ([a1].Value & " heures lol" & Chr(10) & "C'est trop tôt pour travailler !") '& Chr(10) &
[a1].Select
Exit Sub
End If

Target = ""
Dim DatMin As Date, DatMax As Date
Select Case LCase(Sh.Name)
Case "saisierdv":
     ' CELLULE(E14)- en majuscule - Date en cours à +3mois avec heure obligatoire
    If Target(1).Address(False, False) = "E7" Then 'voir si besoin code "suivisappels"
       DatMin = Date      '<date en cours
       DatMax = Date + 90 '<date en cours +90jrs
       Application.EnableEvents = False
       fmSTD_Calendrier.SelectDateCELL2 DatMin, DatMax  '< saisie date qui sera collée dans la cellule active
       If IsDate(Target.Value) Then fm_SaisieHeure.Show '< saisie heure(que s'il y a une date sur cell)
       Application.EnableEvents = True: Cancel = True: Exit Sub
     ' CELLULE(G8) - Date en cours à +/-3mois avec/sans saisie heure
    ElseIf Target(1).Address(False, False) = "G6" Then
       DatMin = Date + 1 '<date en cours -90jrs
       DatMax = Date + 90 '<date en cours +90jrs
       Application.EnableEvents = False
       fmSTD_Calendrier.SelectDateCELL2 DatMin, DatMax  '< saisie date qui sera collée dans la cellule active
       'If IsDate(Target.Value) Then fm_SaisieHeure.Show '< saisie heure(que s'il y a une date sur cell)
       Application.EnableEvents = True: Cancel = True: Exit Sub
    End If
     ' COLONNE(V) à partir de la ligne(7) (test dern.lig/Col(A)
     ' saisie à la Date en cours avec/sans saisie heure
Case "suivisappels":
       If Cells(ActiveCell.Row, 1) = "" Then
'       MsgBox ("y a rien sur cette ligne !") '& Chr(10) &
'       [a1].Select
'       Exit Sub
'       Else
       If Not Application.Intersect(Target, Range("j7:j31")) Is Nothing Then
       '--------------------------------------------------------------------------------
       'ancien code col 22
       'NoLig = Target(1).Row: PremLig = 7: NoCol = 10
       DernLig = Cells(Rows.Count, "A").End(xlUp).Row
       'If Target(1).Column <> NoCol Or NoLig < PremLig Or NoLig > DernLig Then Exit Sub
        '--------------------------------------------------------------------------------
       DatMin = Date   'date en cours
       DatMax = Date + 365 'date en cours +365 jrs à voir!?
       Application.EnableEvents = False
       fmSTD_Calendrier.SelectDateCELL2 DatMin, DatMax  '< saisie date qui sera collée dans la cellule active
       On Error Resume Next
       If IsDate(Target.Value) Then fm_SaisieHeure_SAp.Show '< saisie heure(que s'il y a une date sur cell)
       Application.EnableEvents = True: Cancel = True: Exit Sub
       End If
       End If
End Select
End Sub

Je voudrais pouvoir l'exécuter en simple clic gauche et j'ai simplement fait ce qui suit :

Private Sub Worksheet_SelectionChange(ByVal R As Range)
If Not Intersect(R, Range("j7:j31")) Is Nothing Then
If Hour(Now) < 8 Then
'If [a1] < 8 Then
MsgBox ([a1].Value & " heures lol" & Chr(10) & "C'est trop tôt pour travailler !") '& Chr(10) &
[a1].Select
Exit Sub
End If

R = ""
Dim DatMin As Date, DatMax As Date
Select Case LCase(Sh.Name)
Case "saisierdv":
     ' CELLULE(E14)- en majuscule - Date en cours à +3mois avec heure obligatoire
    If R(1).Address(False, False) = "E7" Then 'voir si besoin code "suivisappels"
       DatMin = Date      '<date en cours
       DatMax = Date + 90 '<date en cours +90jrs
       Application.EnableEvents = False
       fmSTD_Calendrier.SelectDateCELL2 DatMin, DatMax  '< saisie date qui sera collée dans la cellule active
       If IsDate(R.Value) Then fm_SaisieHeure.Show '< saisie heure(que s'il y a une date sur cell)
       Application.EnableEvents = True: Cancel = True: Exit Sub
     ' CELLULE(G8) - Date en cours à +/-3mois avec/sans saisie heure
    ElseIf R(1).Address(False, False) = "G6" Then
       DatMin = Date + 1 '<date en cours -90jrs
       DatMax = Date + 90 '<date en cours +90jrs
       Application.EnableEvents = False
       fmSTD_Calendrier.SelectDateCELL2 DatMin, DatMax  '< saisie date qui sera collée dans la cellule active
       'If IsDate(R.Value) Then fm_SaisieHeure.Show '< saisie heure(que s'il y a une date sur cell)
       Application.EnableEvents = True: Cancel = True: Exit Sub
    End If
     ' COLONNE(V) à partir de la ligne(7) (test dern.lig/Col(A)
     ' saisie à la Date en cours avec/sans saisie heure
    Case "suivisappels":
       If Cells(ActiveCell.Row, 1) = "" Then
'       MsgBox ("y a rien sur cette ligne !") '& Chr(10) &
'       [a1].Select
'       Exit Sub
'       Else
'       If Not Application.Intersect(R, Range("j7:j31")) Is Nothing Then
       '--------------------------------------------------------------------------------
       'ancien code col 22
       'NoLig = R(1).Row: PremLig = 7: NoCol = 10
       DernLig = Cells(Rows.Count, "A").End(xlUp).Row
       'If R(1).Column <> NoCol Or NoLig < PremLig Or NoLig > DernLig Then Exit Sub
        '--------------------------------------------------------------------------------
       DatMin = Date   'date en cours
       DatMax = Date + 365 'date en cours +365 jrs à voir!?
       Application.EnableEvents = False
       fmSTD_Calendrier.SelectDateCELL2 DatMin, DatMax  '< saisie date qui sera collée dans la cellule active
       On Error Resume Next
       If IsDate(R.Value) Then fm_SaisieHeure_SAp.Show '< saisie heure(que s'il y a une date sur cell)
       Application.EnableEvents = True: Cancel = True: Exit Sub
       End If
'       End If
End Select
End If
EnD Sub

J'ai remplacé les "target" par "R".
J'ai le message d'erreur suivent :

sur cette ligne
R = ""
Dim DatMin As Date, DatMax As Date
Select Case LCase(Sh.Name)
je ne trouve pas pourquoi Grrr !!!
Si besoin, je joins le fichier test.
Auriez-vous une piste ?
Je vous remercie,
lionel

 

[Usine à gaz]

Re-Bonjour,

Résolu par laurent950,

R = ""
Dim DatMin As Date, DatMax As Date
Select Case LCase(R.Parent.Name)

en remplacement de

R = ""
Dim DatMin As Date, DatMax As Date
Select Case LCase(Sh.Name)

@laurent
Génial : tu es un magicien
Merci à toi.
lionel,

 

[Usine à gaz]

Re à toutes et à tous,

Voici le fichier contenant les 2 Calendriers (de Patrick et de RolandM) avec les explications de Laurent pour le Calendrier de Roland.
Merci à tous les trois
lionel

 

[Usine à gaz]

Re à toutes et à tous,
Ci-joint fichier mis à jour :
RdV = obligé de sélectionner date et heure
lionel

 

[Usine à gaz]

Bonjour à toutes et à tous,
Ci-joint fichier avec corrections p'tits beugs

 

[cp4]

Bonjour à toutes et à tous,
Ci-joint fichier avec corrections p'tits beugs

Bonjour @Usine à gaz ,

Avant tout bonne année 2022, pleine de bonheur, réussite et surtout santé.
Merci pour ce partage. Cependant, au clic gauche dans la colonne H (cal Patrick), le clic sur RdV-Rappel-NPR n'affiche pas le calendrier. Pourquoi?

A+

 

[Usine à gaz]

Bonjour cp4,
Je regarde

 

[Usine à gaz]

Re-Bonjour cp4,
Très bonne année à toi aussi

"RdV-Rappel-NPR n'affiche pas le calendrier. Pourquoi ?"
C'est une option dans mon fichier de travail qui n'existe pas dans le fichier test = donc inactif
J'aurais du l'enlever pour ce fichier test,
lionel

 

[cp4]

Re-Bonjour cp4,
Très bonne année à toi aussi

Regarde la pièce jointe 1126173
"RdV-Rappel-NPR n'affiche pas le calendrier. Pourquoi ?"
C'est une option dans mon fichier de travail qui n'existe pas dans le fichier test = donc inactif
J'aurais du l'enlever pour ce fichier test,
lionel

Ok, très clair.

Bonne journée.

 

[patricktoulon]

re
tiens j'ai retrouvé l'archive avec cette version a l'origine

 

[Usine à gaz]

Bonjour Patrick
Bien reçu.

J'ajoute dans le code ton texte :

'***************************************************************
' collection fausse boite de dialog
'control calendrier avec un userform pour cellule
'auteur patricktoulon sur exceldownloads
'version simply 2.6.0
'date:10/03/2018
'classe bouton clavier intra userform
'fonctionne en mode applicatif
'la cellule cible est determiné a l'initalyse avec activecell
'***************************************************************
et je remplace le fichier sur le fil,
lionel