XL 2016 Déplacer une ligne si elle contient le mot "OUI" dans la colonne T

[Jess88026467]

Bonjour,

J'ai une feuille source où la colonne T donne la condition de transfert de la ligne vers le fichier de destination.

Une fois la ligne dans le fichier de destination je ne souhaite plus la voir apparaitre dans le fichier source.

Pouvez -vous m'aider ?
J'ai déja essayé plusieurs macro mais il n'y a toujours un problème. Celle qui se rapproche le plus de mes attentes est :
(celle ci transfert si le code reconnait le chiffre 1 dans la ligne, je souhaite juste remplacer "1& par "OUI" et sélectionner la colonne T)

Sub Archivageformation()

Dim I As Long, Plage As Range, Ligne As Long
On Error Resume Next
Ligne = Sheets("Formation (archives)").Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
If Err.Number > 0 Then Ligne = 0
On Error GoTo 0
With Sheets("Formation (personnel)")
For I = 1 To .Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
If Application.CountIf(.Rows(I), 1) > 0 Then
Ligne = Ligne + 1
.Rows(I).Copy Sheets("Formation (archives)").Cells(Ligne, 1)
End If

Next I
For I = .Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row To 1 Step -1
If Application.CountIf(Rows(I), 1) > 0 Then
Rows(I).Delete
End If
Next I
End With
End Sub

Merci pour votre aide, je n'ai aucunes bases en VBA et il est compliqué poiur moi d'adapter les codes.

 

[Backhandshot]

Bonjour à tous !
Voici le code pour ta demande
La colonne T doit contenir "oui" comme tu as demandé
Vois si cela te convient

Sub Archivageformation()
Dim MotCle
Dim i As Byte
Dim C As Range
Dim F As String
Dim Ligne As Long
'On définit les mots clés
MotCle = Array("oui")
'On effectue la recherche de chaque mot clé dans la colonne F de la sheet1
For i = 0 To UBound(MotCle)
Do
Set C = Worksheets("Formation(personnel)").Columns(20).Find(MotCle(i), LookIn:=xlValues, lookat:=xlPart)
'Si le mot clé est trouvé
If Not C Is Nothing Then
'On définit le nom de la feuille où sera effectuée la copie
F = "Formation(archives)"
With Worksheets(F)
'On définit la ligne où sera effectué le collage
Ligne = .Range("A" & Rows.Count).End(xlUp).Row + 1
'On effectue le copier / coller
C.EntireRow.Copy .Range("A" & Ligne)
'On supprime la ligne dans la sheet1
C.EntireRow.Delete
End With
End If
Loop While Not C Is Nothing
Next i
End Sub

 

[Robert]

Bonjour Jess et bienvenu, bonjour le forum,

Merci pour votre aide, je n'ai aucunes bases en VBA et il est compliqué poiur moi d'adapter les codes.

Nous nous avons beaucoup de mal à créer un code sans fichier exemple (avec la même structure que l'original)...

 

[Jess88026467]

Bonjour à vous deux,

BackandShot : je te remercie pour ton code il a très bien fonctionné! Entre temps j'en ai trouvé un second (je vous le partage, si jamais je peux aider à mon tour)

'Macro pour archiver les formations du personnel qui est parti.
Sub Bouton4_Cliquer_Archivage()

A = Worksheets("Formation (personnel)").Cells(Rows.Count, 2).End(xlUp).Row

For i = A To 2 Step -1
If Worksheets("Formation (personnel)").Cells(i, 20).Value = "OUI" Then
Worksheets("Formation (personnel)").Rows(i).Copy Worksheets("Formation (archives)").Cells(Worksheets("Formation (archives)").Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
Worksheets("Formation (personnel)").Rows(i).EntireRow.Delete

End If
Next
End Sub

Robert : oui vous avez raison, c'est vrai que je pensais qu'une petite explication suffit mais c'est vrai qu'un fichier est tout de suite plus parlant. J'y ferais attention la prochaine fois que j'aurais besoin d'aide.

Merci encore et bonne journée

 

[Phil69970]

Bonjour Jess, le forum

Je te propse ceci :

Sub Archivageformation()
Application.ScreenUpdating = False
Dim Derlig1&, Derlig2&

Dim Sh1 As Worksheet
Dim Sh2 As Worksheet

Set Sh1 = Sheets("Formation (personnel)")
Set Sh2 = Sheets("Formation (archives)")

Derlig1 = Sh1.Range("A" & Rows.Count).End(xlUp).Row
Derlig2 = Sh2.Range("A" & Rows.Count).End(xlUp).Row + 1

For i = Derlig1 To 2 Step -1
    With Sh1
        If .Range("T" & i) = "OUI" Or .Range("T" & i) = "oui" Or .Range("T" & i) = "Oui" Then
            .Range("A" & i & ":T" & i).Copy Sh2.Range("A" & Derlig2)
            .Range("A" & i).EntireRow.Delete
            Derlig2 = Derlig2 + 1
        End If
    End With
Next i

Set Sh1 = Nothing
Set Sh2 = Nothing
End Sub

@Phil69970