Microsoft 365 Interdire L'écriture sur une ligne si la date est dépassée

sebastien176

XLDnaute Nouveau
Bonjour à tous,

J’aimerais verrouiller toutes les cellules (liste déroulante) d'une ligne (à partir de la ligne 6) si la date (colonne 2) est dépassée

Si possible j'aimerais qu'il soit quand même possible de pouvoir remplir les cellules jusqu'à 2 jours avants la date du jour

Je vous remercie par avance de votre aide

Vous trouverez le fichier en pièce jointe ;)

Bonne journée

Seb
 

Pièces jointes

  • Véroullage cellule date depasse.xlsm
    156.7 KB · Affichages: 8

Lolote83

XLDnaute Barbatruc
Salut SEBASTIEN176,
Voici un petit fichier exemple qui pourrait peut être correspondre à ta demande
@+ Lolote83
 

Pièces jointes

  • Copie de SEBASTIEN176 - Liste déroulante spéciale.xlsx
    27.2 KB · Affichages: 9
Dernière édition:

sebastien176

XLDnaute Nouveau
Salut SENASTIEN176,
Voici un petit fichier exemple qui pourrait peut être correspondre à ta demande
@+ Lolote83
Salut Lolote83,

Merci pour ta réponse .... je suis désolé d'avance mais j'ai oublié 2 petites précisions
Je préférerais passer en mode VBA pour avoir un message box pour prévenir l'utilisateur qu'il na peut plus modifier la case car la date est dépassée de plus de 2 jours

Merci quand même pour ton aide

Seb
 

sebastien176

XLDnaute Nouveau
Pour info les cases qui contiennent la date sont fusionnées .... donc j'ai refais une colonne qui sera masquer dans le fichier ci-joint
j'ai également essayer avec ce code mais il y a des bugs

Merci d'avance de vos réponses

'Interdire la saisie quand la date est dépassée sur la feuille
'Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'If Not Intersect(Target, Range("E7:ZZ1200")) Is Nothing Then
'jour = Cells(3, Target.Column).Value
'If Date - 1 > jour Then
'MsgBox ("Vous ne pouvez pas revenir à une date précedente")
'[A1].Select
'Exit Sub
'End If

'If jour > Date + 1 Then
'MsgBox ("Vous ne pouvez pas remplir à l'avance")
'[A1].Select
'Exit Sub
'End If

'End If
'End Sub
 

Pièces jointes

  • Véroullage cellule date depasse.xlsm
    181.4 KB · Affichages: 4

fanch55

XLDnaute Barbatruc
Bonjour à tous,
Classeur adapté à tester.
Seule la feuille Suivi TPM Emballage a été impactée :
Ajout
VB:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim R As Range

    Select Case True
        Case Target.Count > 1
        Case Intersect(Target, [D7:T1119]) Is Nothing
        Case Not CheckDate
            Application.EnableEvents = False
            Set R = Columns("B").Find(Format(Date - 2, "dddd dd mmmm"), LookIn:=xlValues)
            If Not R Is Nothing Then Cells(R.Row, "B").Select Else Cells(Target.Row, "B").Select
            Application.EnableEvents = True
    End Select
End Sub
Function CheckDate() As Boolean
Dim Refdate As Date
    
    CheckDate = True
    Refdate = Cells(Selection.Row, "B").MergeArea.Cells(1).Value
    
    Select Case Date
        Case Is > Refdate + 2:  MsgBox "trop tard": CheckDate = False
        Case Is >= Refdate + 1: MsgBox "il est temps"
        Case Else
    End Select
    
End Function

Modifié: ( ne devrait pas se déclencher sauf si modif par code .)
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim fait, x As String

Dim R As Range
    Select Case True
        Case Target.Count > 1
        Case Intersect(Target, [D7:T1119]) Is Nothing
        Case Not CheckDate
            Application.EnableEvents = False
            Application.Undo
            Set R = Columns("B").Find(Format(Date - 2, "dddd dd mmmm"), LookIn:=xlValues)
            If Not R Is Nothing Then Cells(R.Row, "B").Select Else Cells(Target.Row, "B").Select
            Application.EnableEvents = True
    End Select

fait = ActiveCell.Value
.....
.....
 

Pièces jointes

  • Véroullage cellule date depasse.xlsm
    159.6 KB · Affichages: 5

job75

XLDnaute Barbatruc
Bonjour sebastien176, Lolote83, fanch55,

Si j'ai bien compris cette macro doit faire l'affaire :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lig As Variant
lig = Application.Match(CDbl(Date - 2), [B:B])
If IsError(lig) Then Exit Sub
If Intersect(Target, Rows("7:" & lig + 2)) Is Nothing Then Exit Sub
Application.EnableEvents = False 'désactive les évènements
Application.Undo 'annule les modifications
Application.EnableEvents = True 'réactive les évènements
End Sub
Dans le fichier joint j'ai supprimé la colonne des dates C qui ne servait à rien.

A+
 

Pièces jointes

  • Véroullage cellule date depasse(1).xlsm
    156.9 KB · Affichages: 8

Discussions similaires