XL 2019 Verrouiller des lignes si Date

[btakeshi]

Bonjour à vous,

Je suis débutant en Excel et j’ai besoin de l’aide.

La colonne A de ma feuille contient des dates, je souhaite interdire toutes modifications et/ou suppression d’une ligne si la date déjà saisie est inférieure à la date d’aujourd’hui.

Je sollicite aussi votre aide pour contourner le problème du changement manuellement des dates sur l’ordinateur qui permettre de contourner cette interdiction.

Merci pour votre temps.

 

[ivan27]

Bonsoir btakeshi, le forum,

Une proposition en pièce jointe.
Ivan

 

[btakeshi]

Bonjour,
Votre solution est SMART , merci beaucoup.

 

[soan]

Bonsoir btakeshi, ivan27,

Je propose cette optimisation du code VBA d'ivan27 :

Private Sub Worksheet_Activate()
  Dim cel As Range, dlg&: ActiveSheet.Unprotect
  dlg = Cells(Rows.Count, 1).End(3).Row
  For Each cel In Range("A2:A" & dlg)
    cel.Locked = cel < Date
  Next cel
  ActiveSheet.Protect
End Sub

soan

 

[job75]

Bonjour btakeshi, ivan27, soan,

Voyez le fichier joint et cette macro dans le code de la feuille :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim tablo, d As Object, i&, dat As Variant, flag As Boolean
Application.ScreenUpdating = False
tablo = Range("A1", UsedRange).Resize(, 2) 'matrice, plus rapide
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(tablo): d(tablo(i, 1) & tablo(i, 2)) = "": Next
Application.EnableEvents = False 'désactive les évènements
Application.Undo 'annule les modifications
tablo = Range("A1", UsedRange).Resize(, 2) 'matrice, plus rapide
For i = 1 To UBound(tablo)
    dat = tablo(i, 1): flag = False
    If dat = "Date" Then flag = True 'en-tête
    If IsDate(dat) Then If CDate(dat) < Date Then flag = True
    If flag Then If Not d.exists(tablo(i, 1) & tablo(i, 2)) Then GoTo 1
Next
Application.Undo 'rétablit les modifications
1 Application.EnableEvents = True 'réactive les évènements
End Sub

Les lignes des dates écoulées et les en-têtes ne peuvent pas être modifiées ou supprimées.

Il n'y a pas besoin de protéger la feuille.

A+

 

[Arkinoxs]

Bonjour btakeshi, ivan27, soan,

Voyez le fichier joint et cette macro dans le code de la feuille :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim tablo, d As Object, i&, dat As Variant, flag As Boolean
Application.ScreenUpdating = False
tablo = Range("A1", UsedRange).Resize(, 2) 'matrice, plus rapide
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(tablo): d(tablo(i, 1) & tablo(i, 2)) = "": Next
Application.EnableEvents = False 'désactive les évènements
Application.Undo 'annule les modifications
tablo = Range("A1", UsedRange).Resize(, 2) 'matrice, plus rapide
For i = 1 To UBound(tablo)
    dat = tablo(i, 1): flag = False
    If dat = "Date" Then flag = True 'en-tête
    If IsDate(dat) Then If CDate(dat) < Date Then flag = True
    If flag Then If Not d.exists(tablo(i, 1) & tablo(i, 2)) Then GoTo 1
Next
Application.Undo 'rétablit les modifications
1 Application.EnableEvents = True 'réactive les évènements
End Sub

Les lignes des dates écoulées et les en-têtes ne peuvent pas être modifiées ou supprimées.

Il n'y a pas besoin de protéger la feuille.

A+

Salut comment l'adapter sur plusieurs colonne d'une même ligne?

 

[job75]

Bonjour Arkinxs, bienvenue sur XLD, le fil, le forum,

Bravo, vous avez bien fait de revenir sur ce fil, la question est intéressante, voyez ce fichier (2).

Pour traiter plusieurs colonnes il faut concaténer les éléments de chaque ligne du tableau :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim tablo, d As Object, i&, x As Variant, dat As Variant, flag As Boolean
With Application
    .ScreenUpdating = False
    tablo = Range("A1", UsedRange) 'matrice, plus rapide
    Set d = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(tablo)
        x = .Index(tablo, i, 0) 'ligne du tableau
        x = Join(.Transpose(.Transpose(x)), Chr(1)) 'concaténation avec séparateur
        d(x) = ""
    Next
    .EnableEvents = False 'désactive les évènements
    .Undo 'annule les modifications
    tablo = Range("A1", UsedRange) 'matrice, plus rapide
    For i = 1 To UBound(tablo)
        dat = tablo(i, 1): flag = False
        If dat = "Date" Then flag = True 'en-tête
        If IsDate(dat) Then If CDate(dat) < Date Then flag = True
        If flag Then
            x = .Index(tablo, i, 0) 'ligne du tableau
            x = Join(.Transpose(.Transpose(x)), Chr(1)) 'concaténation avec séparateur
            If Not d.exists(x) Then GoTo 1
        End If
    Next
    .Undo 'rétablit les modifications
1   .EnableEvents = True 'réactive les évènements
End With
End Sub

Bien voir que la fonction Join ne concatène qu'un tableau à 1 dimension, d'où les Transpose.

A+

 

[Arkinoxs]

Bonjour Arkinxs, bienvenue sur XLD, le fil, le forum,

Bravo, vous avez bien fait de revenir sur ce fil, la question est intéressante, voyez ce fichier (2).

Pour traiter plusieurs colonnes il faut concaténer les éléments de chaque ligne du tableau :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim tablo, d As Object, i&, x As Variant, dat As Variant, flag As Boolean
With Application
    .ScreenUpdating = False
    tablo = Range("A1", UsedRange) 'matrice, plus rapide
    Set d = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(tablo)
        x = .Index(tablo, i, 0) 'ligne du tableau
        x = Join(.Transpose(.Transpose(x)), Chr(1)) 'concaténation avec séparateur
        d(x) = ""
    Next
    .EnableEvents = False 'désactive les évènements
    .Undo 'annule les modifications
    tablo = Range("A1", UsedRange) 'matrice, plus rapide
    For i = 1 To UBound(tablo)
        dat = tablo(i, 1): flag = False
        If dat = "Date" Then flag = True 'en-tête
        If IsDate(dat) Then If CDate(dat) < Date Then flag = True
        If flag Then
            x = .Index(tablo, i, 0) 'ligne du tableau
            x = Join(.Transpose(.Transpose(x)), Chr(1)) 'concaténation avec séparateur
            If Not d.exists(x) Then GoTo 1
        End If
    Next
    .Undo 'rétablit les modifications
1   .EnableEvents = True 'réactive les évènements
End With
End Sub

Bien voir que la fonction Join ne concatène qu'un tableau à 1 dimension, d'où les Transpose.

A+

Bonjour,
Merci pour ta réponse, nous avons effectivement un ligne complète qui ne peut être modifié avec ce code.
Entre temps j'ai trouvé un code VBA que j'ai modifié afin d'obtenir l'option de choisir chaque colonne de la ligne dont nous avons besoin de verrouiller lorsque la date d'une cellule de la même ligne est antérieur à aujourd'hui. Voici :

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
  Dim xRow As Long
  xRow = 2
  ThisWorkbook.ActiveSheet.Unprotect Password:="123"
  ThisWorkbook.ActiveSheet.Cells.Locked = False
  'Lechiffre "1" ci dessous est celui de la colonne contenant la date
  Do Until IsEmpty(Cells(xRow, 1))
    If Cells(xRow, 1) < Date Then
'Les chiffre ci-dessous sont les colonnes à être verouillé(on peut en ajouter ou enlever selon le besoin)
       Cells(xRow, 1).Locked = True
       Cells(xRow, 2).Locked = True
       Cells(xRow, 3).Locked = True
       Cells(xRow, 4).Locked = True
       Cells(xRow, 5).Locked = True
       Cells(xRow, 6).Locked = True
       Cells(xRow, 7).Locked = True
       Cells(xRow, 8).Locked = True
    End If
    xRow = xRow + 1
  Loop
  ThisWorkbook.ActiveSheet.Protect Password:="123"
End Sub

 

[job75]

Votre code ne va pas car il faut que le verrouillage se fasse avant la modification et pas après.