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

sambio2 à dit:

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.

Cliquez pour agrandir...

sambio2 à dit:

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

Cliquez pour agrandir...

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

sylvanu à dit:

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 :

VB:

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

Cliquez pour agrandir...

job75 à dit:

Bonjour sambio2, sylvanu,

Voici une autre solution VBA.

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

Code:

=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é" :

VB:

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+

Cliquez pour agrandir...

sambio2 à dit:

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

Cliquez pour agrandir...

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