Supprimer les lignes copier suivant condition

Bonjour,

Voici mon problème :

Lorsque je lance la macro "transfert" de la feuille 1, les lignes ou la condition "validé" de la colonne M est remplie sont copiées vers la feuille 2 sur la première ligne vide, jusque la çà fonctionne, mais je voudrai qu'une fois copier les lignes soient supprimées de la feuille 1.

J'ai essayé plusieurs code mais je supprime mon tableau,

Voici un fichier exemple,

Merci de votre aide

Juspe

Salut juspe et

à tester

Sub transfert()

Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CEL As Range 'déclare la variable CEL (CELlule)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)

ActiveCell.Select 'enlève le focus au bouton
Set OS = Worksheets("Feuil1") 'définit l'onglet source OS
Set OD = Worksheets("Feuil2") 'définit l'onglet destination OD
    If MsgBox("Etes-vous certain de vouloir transférer les lignes validées ?", vbYesNo, "Demande de confirmation") = vbYes Then

For Each CEL In OS.Range("M3:M" & OS.Cells(Application.Rows.Count, 13).End(xlUp).Row) 'boucle sur toutes les cellules de la colonne M
    If CEL.Value = "Validé" Then 'condition : si la cellule CEL vaut "Validé"
        Set DEST = OD.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST

            OS.Cells(CEL.Row, 1).Copy DEST 'copie le N°de fiche
            OS.Cells(CEL.Row, 2).Copy DEST.Offset(0, 1) 'copie l'année
            OS.Cells(CEL.Row, 3).Copy DEST.Offset(0, 2) 'copie le N° Sem
            OS.Cells(CEL.Row, 4).Copy DEST.Offset(0, 3) 'copie le N° de page
            OS.Cells(CEL.Row, 5).Copy DEST.Offset(0, 4) 'copie le CU
            OS.Cells(CEL.Row, 6).Copy DEST.Offset(0, 5) 'copie l'opérateur
            OS.Cells(CEL.Row, 7).Copy DEST.Offset(0, 6) 'copie la localisation
            OS.Cells(CEL.Row, 8).Copy DEST.Offset(0, 7) 'copie le point maintenance
            OS.Cells(CEL.Row, 9).Copy DEST.Offset(0, 8) 'copie la Pris en compte
            OS.Cells(CEL.Row, 10).Copy DEST.Offset(0, 9) 'copie le N° Tache Planning
            OS.Cells(CEL.Row, 11).Copy DEST.Offset(0, 10) 'copie le Commentaire maintenance
            OS.Cells(CEL.Row, 12).Copy DEST.Offset(0, 11) 'copie le Délai
            CEL.EntireRow.Delete
        End If 'fin de la condition
    Next CEL
  MsgBox "Fin du transfert !"
End If
End Sub

Bonne journée

Depuis le rajout de la ligne pour supprimer

CEL.EntireRow.Delete

Il faut que j'exécute plusieurs fois la macro pour copier t supprimer toutes les lignes.

N'y a t'il pas une autre méthode ?

Merci

oui c'est normal, il faut changer le sens de la recherche du bas vers le haut.

J'ai pas assez de temps mais demain je te realise ca!

Bonne journée

Bonjour m3ellem1,

J'ai refait d'autres tests mais je m'enterre.

Merci à bientôt

Juspe

Salut juspe,

j'ai fait quelques changements, mais je pense que ca devrait fonctionner.

Sub transfert()
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim xRg As Range
Dim I, J, K As Long

ActiveCell.Select 'enlève le focus au bouton
Set OS = Worksheets("Feuil1") 'définit l'onglet source OS
Set OD = Worksheets("Feuil2") 'définit l'onglet destination OD
If MsgBox("Etes-vous certain de vouloir transférer les lignes validées ?", vbYesNo, "Demande de confirmation") = vbYes Then

   I = OS.UsedRange.Rows.Count ' nbr de lignes utilisées dans l'onglet source OS
   J = OD.UsedRange.Rows.Count + 1 ' nbr de lignes utilisées dans l'onglet source OS +1 (Ligne 1 est vide!)
   Set xRg = OS.Range("M3:M" & I)
   On Error Resume Next
   Application.ScreenUpdating = False
    For K = 1 To xRg.Count
        If CStr(xRg(K).Value) = "Validé" Then
            OS.Range("A" & xRg(K).Row & ":L" & xRg(K).Row).Copy Destination:=OD.Range("A" & J + 1)
            xRg(K).EntireRow.Delete
            If CStr(xRg(K).Value) = "Validé" Then
            K = K - 1
            End If
            J = J + 1
        End If
    Next K
   MsgBox "Fin du transfert !"
   Application.ScreenUpdating = True
End If
End Sub

Bonne nuit

Bonjour m3ellem3,

Merci, le code fonctionne très et avec rapidité.

j'ai compris une partie de ta méthode mais je ne connaissais pas la fonction conversion CStr.

Bonne Journée

Juspe