XL 2010 archive de ligne si ... (par macro)

erwanhavre

XLDnaute Occasionnel
Bonsoir à tous je cherche par le moyen d'un bouton à archiver toutes les lignes dont la date figurant dans la colonne K est supérieur à 10 jours par rapport à la date du jour
Je pensais à un couper coller des lignes concernées vers l'onglet archives mais je n'y arrive pas

Petite précision c'est un fichier partagé

Merci à tous
 

Pièces jointes

  • planning.xlsx
    12 KB · Affichages: 36

DoubleZero

XLDnaute Barbatruc
Bonjour, erwanhavre, Jacky67 :), le Forum,

Comme ceci ?
VB:
Option Explicit
Sub Archiver()
    Dim quand As Date, i As Long, ii As Long
    With Application: .ScreenUpdating = False: .Calculation = xlManual: .EnableEvents = False: End With
    Sheets("suivi").Activate
    On Error Resume Next
    quand = Date - 11
    ii = 2
    For i = 2 To Range("k65535").End(xlUp).Row
        If Cells(i, 11) <= quand Then
            With Cells(i, 11)
                .Offset(, -10).Resize(, 18).Cut Destination:=Sheets("Archives").Range("a" & Rows.Count).End(xlUp)(2)
            End With
            ii = ii + 1
        End If
    Next i
    Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
    With Application: .EnableEvents = True: .Calculation = xlAutomatic: .ScreenUpdating = True: End With
End Sub
A bientôt :)
 

DoubleZero

XLDnaute Barbatruc
Bonjour à toutes et à tous,

Une autre version, sans boucle :
VB:
Option Explicit
Sub Archiver_v2()
    With Application: .ScreenUpdating = False: .Calculation = xlManual: .EnableEvents = False: End With
    Columns(1).Insert
    Range("a2:a" & Cells(Rows.Count, 2).End(xlUp).Row).FormulaR1C1 = "=IF(RC[11]<=TODAY()-11,""ok"",""nok"")"
    With Range("a1"): .Value = "?": .AutoFilter: End With
    Range("a1:s65000").AutoFilter Field:=1, Criteria1:="ok"
    On Error Resume Next
    With Range(Range("b2"), Range("b2").End(xlToRight).End(xlDown)).SpecialCells(xlCellTypeVisible). _
         SpecialCells(xlCellTypeConstants)
        .Copy Destination:=Sheets("Archives").Range("a" & Rows.Count).End(xlUp)(2)
        .EntireRow.Delete
    End With
    On Error GoTo 0
    Columns(1).Delete: Cells.AutoFilter
    With Application: .EnableEvents = True: .Calculation = xlAutomatic: .ScreenUpdating = True: End With
End Sub
A bientôt :)
 

Discussions similaires

Réponses
3
Affichages
351

Statistiques des forums

Discussions
311 725
Messages
2 081 941
Membres
101 846
dernier inscrit
Silhabib