Copier/Coller en boucle avec condition

[arnaudbu]

Bonjour, et oui encore moi. Je vous promet mon projet avance à grand pas 😉

La fonction recherche m'a donnée des petits bouts de code que j'ai essayé d'adapter.

Voili, voilou .... En rapport avec un autre post, j'aimerais faire une boucle qui:
-me copie toutes les lignes de Feuil1!A7😛 si en P il y a "OK"
-puis les colle à la suite de Feuil2 avec maintient mise en forme et valeur (mais sans formule)
-puis efface ces dernières sur Feuil1.

Mon laborieux essai:

With Sheets("Feuil1")
    
    For cpt1 = Range("A65536").End(xlUp).Row To cpt1 Step 1
    
      Set rd = Sheets("Feuil2").Range("A65536").End(xlUp).Offset(1, 0)
      Set rs = .Range("A" & cpt1).Resize(1, 16)
      
        If Range("P" & cpt1) = "OK" Then
        rs.Copy
  
        rd.PasteSpecial xlValues
        rd.PasteSpecial xlFormats
  
        End If
         
    Next cpt1
        
End With

 

[arnaudbu]

Re : Copier/Coller en boucle avec condition

Une piste, une idée ??

 

[Modeste]

Re : Copier/Coller en boucle avec condition

Bonsoir arnaudbu,

Mon laborieux essai:

... Je ne me prononce pas, je propose une variante qui a le mérite d'être simple à comprendre:

Sub test()
Dim cpt1%, cpt2%
cpt2 = 1
Application.ScreenUpdating = False
With Sheets("Feuil1")
    For cpt1 = 1 To .Range("A65536").End(xlUp).Row
        If .Range("P" & cpt1) = "OK" Then
            .Range("A" & cpt1 & ":P" & cpt1).Copy
            Sheets("Feuil2").Range("A" & cpt2).PasteSpecial xlValues
            Sheets("Feuil2").Range("A" & cpt2).PasteSpecial xlFormats
            cpt2 = cpt2 + 1
        End If
    Next cpt1
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[arnaudbu]

Re : Copier/Coller en boucle avec condition

Merci pour la réponse et surtout pour l'aide. J'ai un peu adapté le code avec mon premier code mais en corrigeant les erreurs grace à ton aide:

Sub Archivage()

Dim MSG As Long, rd As Range, rs As Range

MSG = MsgBox("Cette action va archiver !." _
& vbNewLine & " " & vbNewLine & "Effacer les actions et archiver ?", _
vbQuestion + vbYesNo, "Information")

If MSG = vbYes Then

Application.ScreenUpdating = False

With Sheets("Archive")
    UnProtect 'Module Protection
End With

With Sheets("Suivi")

    UnProtect 'Module Protection
    
    For cpt = 7 To .Range("A65536").End(xlUp).Row
    
        Set rd = Sheets("Archive").Range("A65536").End(xlUp).Offset(1, 0)
        Set rs = .Range("A" & cpt & ":P" & cpt)
            
            If .Range("P" & cpt) = "OK" Then
                rs.Copy
                rd.PasteSpecial xlValues
                rd.PasteSpecial xlFormats
                rs.Delete
            End If
    
    Next cpt
    
    Protect 'Module Protection
        
End With

Application.CutCopyMode = False

With Sheets("Archive")
    Protect 'Module Protection
End With

Application.ScreenUpdating = True

End If

End Sub

 

[arnaudbu]

Re : Copier/Coller en boucle avec condition

J'ai juste une erreur ici: rs.Delete Méthode delete de la classe Range à échoué.

Pourtant ca avait l'air de fonctionner 😕

 

[arnaudbu]

Re : Copier/Coller en boucle avec condition

Résolu: problème de protection. @+