Déplacer des données sur une feuille "mémoire"

[ascal44]

Bonsoir , je sollicite encore une fois votre aide.

J'ai ce code à modifier pour ne pas effacer mais déplacer les valeures sur une feuille nommée "mémoire" afin de les garder en archive.

Sub efface()
 With Sheets("Alertes")
  For li = [B6550].End(xlUp).Row To 2 Step -1
    If Cells(li, 2) < Date Then Cells(li, 2).[COLOR="Red"]EntireRow.Delete[/COLOR]  Next
  End With
End Sub

En vous remerciant par avance

 

[kjin]

Re : Déplacer des données sur une feuille "mémoire"

Bonsoir ascal44,
Avec 323 au compteur, toujours pas croisé Henry Gistrair de MacRow ?
A+
kjin

 

[ascal44]

Re : Déplacer des données sur une feuille "mémoire"

Non je ne l'ai pas croisé.
Je ne comprends pas le sens de la question.

 

[Fred0o]

Re : Déplacer des données sur une feuille "mémoire"

Bonsoir ascal, kjin, Henry,

On peut aussi demander au maquereau record d'heure !

A+

 

[ascal44]

Re : Déplacer des données sur une feuille "mémoire"

OK , j'ai compris la plaisanterie.
Oui j'ai tenté l'enregistreur de macro.
Mais je ne vois pas comment arranger le code pour copier les valeures à la suite dans la feuille "mémoire"

 

[Fred0o]

Re : Déplacer des données sur une feuille "mémoire"

Re-bonsoir ascal,

Tu peux tester ton code sur ton fichier :

Sub copie()
    Dim li
    With Sheets("Alertes")
        For li = [B6550].End(xlUp).Row To 2 Step -1
            If Cells(li, 2) < Date Then
                Rows(li).Select
                Selection.Cut
                Sheets("memoire").Select
                Cells(Range("B65536").End(xlUp).Row + 1, 1).EntireRow.Select
                ActiveSheet.Paste
                Sheets("Alertes").Select
                Selection.Delete Shift:=xlUp
            End If
        Next
    End With
End Sub

A+

 

[ascal44]

Re : Déplacer des données sur une feuille "mémoire"

Merci FredOo , tu as bien compris mon souhait : cela fonctionne.

 

[ROGER2327]

Re : Déplacer des données sur une feuille "mémoire"

Bonsoir à tous

Histoire d'accélérer la manœuvre :

[COLOR=DarkSlateGray][B]Sub copie()
Dim li
  With Application: .ScreenUpdating = 0: .Calculation = -4135: End With
  With Sheets("Alertes")
    For li = .[B6550].End(xlUp).Row To 2 Step -1
      If .Cells(li, 2) < Date Then
        .Rows(li).EntireRow.Cut Destination:=Sheets("memoire").Cells(Sheets("memoire").Range("B65536").End(xlUp).Row + 1, 1)
        .Rows(li).EntireRow.Delete Shift:=xlUp
      End If
    Next
  End With
  With Application: .Calculation = -4105: .ScreenUpdating = 1: End With
End Sub[/B][/COLOR]

ROGER2327
#4699

Samedi 7 Sable 138 (Saint Birbe, juge, SQ)
17 Frimaire An CCXIX
2010-W49-2T23:03:48Z