Microsoft 365 Calendrier : Modifier Target > change R

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
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 :
VB:
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 :
Code:
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 :
1640956560870.png


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

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
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 :)
 

Statistiques des forums

Discussions
297 994
Messages
1 964 950
Membres
200 778
dernier inscrit
ons123