XL 2021 Suppression d'une ligne si date dépassée

[sambio2]

Bonjour,

Je suis actuellement sur le sujet d'un fichier pour répertorier des bouteilles de GAZ, sur ma liste d'archives, je voulais savoir s'il y avait une formule pour dire qu'une fois la "date de départ" dépassé de 5 ans, la ligne serait supprimée automatiquement.

je vous mets le fichier ci-joint, en vous remerciant d'avance

Bonne journée.

 

[sylvanu]

Bonjour Sambio,

s'il y avait une formule pour dire qu'une fois la "date de départ" dépassé de 5 ans, la ligne serait supprimée automatiquement.

Une formule ne peut pas supprimer une ligne, mais on peut le faire par ex en VBA à la condition que vous acceptiez les macros.
On peut aussi masquer ces lignes, et non les supprimer, avec un filtrage sur une colonne supplémentaire. Voir PJ. Il suffit en colonne Q de filtrer que sur "Vide"

 

[sambio2]

Bonjour Sylvanu,

Merci pour ton retour. Le but étant de ne pas avoir une base de donnée trop importante avec le temps et donc de supprimer les lignes, est-il possible que faire une VBA qui fasse cette action automatiquement (sans avoir à appuyer sur un bouton pour actualisé) ?

 

[sylvanu]

Re,
1- Toutes vos dates sont du texte et non des nombres, ce qui ne simplifie pas les choses.
2- Le 30 février (ligne 9) ! c'est assez vicieux à trouver.

VBA qui fasse cette action automatiquement (sans avoir à appuyer sur un bouton pour actualisé)

Encore faut il trouver sur quel événement on déclenche la macro.

En PJ un essai. Il faut plus d'une feuille dans le classeur. La macro est automatique lorsqu'on choisit la feuille Archives bouteille GAZ PERL avec :

Sub Worksheet_Activate()
Dim L%, N%, T, Départ
Application.ScreenUpdating = False
For L = [A10000].End(xlUp).Row To 4 Step -1
    If Cells(L, "P") <> "" Then
        T = Split(Cells(L, "P"), "/")
        On Error Resume Next
        Départ = CDate(T(2) & "/" & T(1) & "/" & T(0))
        If Date - Départ > 5 * 365.25 Then Rows(L).Delete Shift:=xlUp: N = N + 1
    End If
Next L
Application.ScreenUpdating = True
If N > 0 Then MsgBox "Nombre de lignes supprimées :  " & N
End Sub

 

[job75]

Bonjour sambio2, sylvanu,

Voici une autre solution VBA.

La colonne auxiliaire Q est utilisée avec la formule :

=REPT("Obsolète";ET(P4<>"";AUJOURDHUI()>=MOIS.DECALER(P4;60)))

Le tableau est filtré sur cette colonne et les lignes filtrées sont transférées en feuille "Supprimé" :

Private Sub Worksheet_Calculate()
Dim F As Worksheet, n&, dest As Range
Set F = Sheets("Supprimé")
With Range("A3:Q" & Cells.SpecialCells(xlCellTypeLastCell).Row)
    n = Application.CountIf(.Columns(17).Offset(1), "Obsolète")
    If n Then MsgBox n & " Obsolète(s) supprimé(s)..." Else Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    .AutoFilter
    .AutoFilter 17, "Obsolète"
    If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
    Set dest = F.Range("A" & F.Range("Q" & F.Rows.Count).End(xlUp).Row + 1)
    With .Offset(1).SpecialCells(xlCellTypeVisible)
        .Copy dest
        .Delete xlUp
    End With
    .AutoFilter
    F.Columns.Autofit 'ajustement largeurs
    Application.EnableEvents = True
End With
End Sub

La macro se déclenche chaque fois que les formules volatiles en colonne Q sont recalculées.

En particulier à l'ouverture du fichier.

A+

 

[sambio2]

Re,
1- Toutes vos dates sont du texte et non des nombres, ce qui ne simplifie pas les choses.
2- Le 30 février (ligne 9) ! c'est assez vicieux à trouver.

Encore faut il trouver sur quel événement on déclenche la macro.

En PJ un essai. Il faut plus d'une feuille dans le classeur. La macro est automatique lorsqu'on choisit la feuille Archives bouteille GAZ PERL avec :

Sub Worksheet_Activate()
Dim L%, N%, T, Départ
Application.ScreenUpdating = False
For L = [A10000].End(xlUp).Row To 4 Step -1
    If Cells(L, "P") <> "" Then
        T = Split(Cells(L, "P"), "/")
        On Error Resume Next
        Départ = CDate(T(2) & "/" & T(1) & "/" & T(0))
        If Date - Départ > 5 * 365.25 Then Rows(L).Delete Shift:=xlUp: N = N + 1
    End If
Next L
Application.ScreenUpdating = True
If N > 0 Then MsgBox "Nombre de lignes supprimées :  " & N
End Sub

Ok Super merci pour la Solution ça fonctionne bien !!

A++

 

[sambio2]

Bonjour sambio2, sylvanu,

Voici une autre solution VBA.

La colonne auxiliaire Q est utilisée avec la formule :

=REPT("Obsolète";ET(P4<>"";AUJOURDHUI()>=MOIS.DECALER(P4;60)))

Le tableau est filtré sur cette colonne et les lignes filtrées sont transférées en feuille "Supprimé" :

Private Sub Worksheet_Calculate()
Dim F As Worksheet, n&, dest As Range
Set F = Sheets("Supprimé")
With Range("A3:Q" & Cells.SpecialCells(xlCellTypeLastCell).Row)
    n = Application.CountIf(.Columns(17).Offset(1), "Obsolète")
    If n Then MsgBox n & " Obsolète(s) supprimé(s)..." Else Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    .AutoFilter
    .AutoFilter 17, "Obsolète"
    If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
    Set dest = F.Range("A" & F.Range("Q" & F.Rows.Count).End(xlUp).Row + 1)
    With .Offset(1).SpecialCells(xlCellTypeVisible)
        .Copy dest
        .Delete xlUp
    End With
    .AutoFilter
    F.Columns.Autofit 'ajustement largeurs
    Application.EnableEvents = True
End With
End Sub

La macro se déclenche chaque fois que les formules volatiles en colonne Q sont recalculées.

En particulier à l'ouverture du fichier.

A+

Merci pour la réponse, cependant j'ai pas vraiment réussi à la mettre en place... et puis sans la colonne Q ça m'arrange bien aussi

 

[job75]

et puis sans la colonne Q ça m'arrange bien aussi

On peut se passer de la colonne auxiliaire Q en utilisant le filtre avancé :

Private Sub Worksheet_Calculate()
Dim F As Worksheet, dest As Range, P As Range
Set F = Sheets("Supprimé")
Application.ScreenUpdating = False
Application.EnableEvents = False
Me.AutoFilterMode = False 'neutralise le filtre automatique
With Range("A3:P" & Cells.SpecialCells(xlCellTypeLastCell).Row)
    .Cells(2, 17) = "=AND(P4<>"""",TODAY()>=EDATE(P4,60))" 'critère rn Q4
    .AdvancedFilter xlFilterInPlace, .Cells(1, 17).Resize(2) 'filtre avancé
    If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
    Set dest = F.Range("A" & F.Range("P" & F.Rows.Count).End(xlUp).Row + 1)
    On Error Resume Next
    Set P = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
    If Not P Is Nothing Then
        P.Copy dest
        MsgBox (P.Count / 16) & " ligne(s) supprimée(s)..."
        P.Delete xlUp
    End If
    .Cells(2, 17) = ""
End With
F.Columns.AutoFit 'ajustement largeurs
If Me.FilterMode Then Me.ShowAllData 'si la feuille est filtrée
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

L'évènement Calculate est créé et la macro s'exécute à condition qu'il y ait une formule volatile.

C'est pour cela que j'ai mis =AUJOURDHUI() en Q2.

 

[job75]

J'ai joint le fichier qui manquait au post #5.