1. Ce site utilise des "témoins de connexion" (cookies) conformes aux textes de l'Union Européenne. Continuer à naviguer sur nos pages vaut acceptation de notre règlement en la matière. En savoir plus.

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

Discussion dans 'Forum Excel' démarrée par erwanhavre, 18 Mai 2017.

  1. erwanhavre

    erwanhavre XLDnaute Occasionnel

    Inscrit depuis le :
    12 Mai 2007
    Messages :
    169
    "J'aime" reçus :
    0
    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:

  2. Jacky67

    Jacky67 XLDnaute Impliqué

    Inscrit depuis le :
    12 Juin 2016
    Messages :
    750
    "J'aime" reçus :
    111
    Bonjour,
    Voir et tester la PJ
     

    Pièces jointes:

  3. erwanhavre

    erwanhavre XLDnaute Occasionnel

    Inscrit depuis le :
    12 Mai 2007
    Messages :
    169
    "J'aime" reçus :
    0
    Bonjour merci par contre est qu'il y à possibilité pour que ça supprime les lignes concerné dans l'onglet suivi ?
    merci merci merci
     
  4. Jacky67

    Jacky67 XLDnaute Impliqué

    Inscrit depuis le :
    12 Juin 2016
    Messages :
    750
    "J'aime" reçus :
    111
    Re..
    Ok, tester la PJ
     

    Pièces jointes:

  5. erwanhavre

    erwanhavre XLDnaute Occasionnel

    Inscrit depuis le :
    12 Mai 2007
    Messages :
    169
    "J'aime" reçus :
    0
    bizar je n'ai pas de résultat ... ai-je fait une fausse manip ?
     
  6. Jacky67

    Jacky67 XLDnaute Impliqué

    Inscrit depuis le :
    12 Juin 2016
    Messages :
    750
    "J'aime" reçus :
    111
    Re...
    Si le premier exemple fonctionnait, je ne vois aucune raison pour que celui-ci ne fonctionne pas.
    Essaye cette version.
    Sinon, mettre en ligne le classeur qui est testé.
     

    Pièces jointes:

  7. erwanhavre

    erwanhavre XLDnaute Occasionnel

    Inscrit depuis le :
    12 Mai 2007
    Messages :
    169
    "J'aime" reçus :
    0
    voir pj j'ai même mis une copie d'écran il ne me transfère rien dans l'onglet archive
     

    Pièces jointes:

  8. Jacky67

    Jacky67 XLDnaute Impliqué

    Inscrit depuis le :
    12 Juin 2016
    Messages :
    750
    "J'aime" reçus :
    111
    Re..
    Je n'arrive pas à reproduire ce que tu décris
    Teste ce classeur et regarde sur quelle ligne il y a plantage
     

    Pièces jointes:

  9. erwanhavre

    erwanhavre XLDnaute Occasionnel

    Inscrit depuis le :
    12 Mai 2007
    Messages :
    169
    "J'aime" reçus :
    0
    .Range("a2:s" & derlg).SpecialCells(xlCellTypeVisible).EntireRow.Delete
     
  10. Jacky67

    Jacky67 XLDnaute Impliqué

    Inscrit depuis le :
    12 Juin 2016
    Messages :
    750
    "J'aime" reçus :
    111
    Re...
    Je n'ai pas cette erreur, la copie se fait, la suppression aussi.(xl2007)
    Je n'ai pas de solution. Désolé
    Je te conseille d'ouvrir un nouveau poste et de poser ce problème , peut-être une particularité à ta version Excel
     
    Dernière édition: 19 Mai 2017
  11. DoubleZero

    DoubleZero XLDnaute Barbatruc

    Inscrit depuis le :
    14 Septembre 2010
    Messages :
    5640
    "J'aime" reçus :
    1165
    Utilise:
    Excel 2013 (PC)
    Bonjour, erwanhavre, Jacky67 :), le Forum,

    Comme ceci ?
    Code (Visual Basic):
    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 :)
     
    arthour973 aime votre message.
  12. Jacky67

    Jacky67 XLDnaute Impliqué

    Inscrit depuis le :
    12 Juin 2016
    Messages :
    750
    "J'aime" reçus :
    111
    Hello 00
    Oui certes, avec une boucle.
    C'est ce que je voulais éviter.
    Ce que je ne comprends pas , pourquoi cela fonctionne chez moi, et pas chez erwanhavre
    As tu essayé mon classeur joint ?
     
  13. DoubleZero

    DoubleZero XLDnaute Barbatruc

    Inscrit depuis le :
    14 Septembre 2010
    Messages :
    5640
    "J'aime" reçus :
    1165
    Utilise:
    Excel 2013 (PC)
    Re-bonjour,
    Oui, j'ai testé. Résultat : fonctionnement pas b:(n !

    Reste à savoir si ma suggestion fonctionne chez erwanhavre et les autres membres.

    A bientôt :)
     
  14. erwanhavre

    erwanhavre XLDnaute Occasionnel

    Inscrit depuis le :
    12 Mai 2007
    Messages :
    169
    "J'aime" reçus :
    0
    C'est bon merci à tous
     
  15. DoubleZero

    DoubleZero XLDnaute Barbatruc

    Inscrit depuis le :
    14 Septembre 2010
    Messages :
    5640
    "J'aime" reçus :
    1165
    Utilise:
    Excel 2013 (PC)
    Bonjour à toutes et à tous,

    Une autre version, sans boucle :
    Code (Visual Basic):
    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 :)
     

Partager cette page