Microsoft 365 Déplacer la place d'une ligne en fonction du texte d'une cellule

[oceanepla]

Bonjour,

J'aimerais déplacer ma ligne après la dernière ligne non vide lorsque que ma cellule F10 contient le mot : Terminé
J'ai essayé cette macro là, mais elle copie la ligne sur une nouvelle feuille alors que j'aimerai qu'elle le fasse sur la même feuille :

Sub project()
Dim sht As Worksheet, dst As Workbook, lastrow&, Ncount&, i&
Set sht = ActiveSheet: Set dst = Workbooks.Add
dst.SaveAs Filename:="Terminé": dst.Sheets.Add.Name = "Terminé"
lastrow = sht.Cells(Rows.count, 1).End(xlUp).Row
sht.Activate: Ncount = 1
For i = 1 To lastrow
If InStr(1, sht.Cells(i, 1).Value, "Terminé", vbTextCompare) > 0 Then
sht.Rows(i).Cut
dst.Sheets("Terminé").Rows(Ncount).Insert Shift:=xlDown
sht.Rows(i).Delete: Ncount = Ncount + 1: i = i - 1
End If
Next i
End Sub


En espérant que vous pourriez m'aider.

Bien cordialement,

 

[fanch55]

Bonjour,
A placer dans le code de la feuille concernée:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count = 1 Then
        lr = Cells(Rows.Count, "F").End(xlUp).Row
        If Range("F" & Target.Row) Like "terminé" And lr > Target.Row Then
            Application.EnableEvents = False
                Rows(Target.Row).Cut Rows(lr + 1)
            Application.EnableEvents = True
        End If
    End If
End Sub

 

[oceanepla]

Bonjour,
A placer dans le code de la feuille concernée:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count = 1 Then
        lr = Cells(Rows.Count, "F").End(xlUp).Row
        If Range("F" & Target.Row) Like "terminé" And lr > Target.Row Then
            Application.EnableEvents = False
                Rows(Target.Row).Cut Rows(lr + 1)
            Application.EnableEvents = True
        End If
    End If
End Sub

Bonjour, merci pour ta réponse mais malheureusement j'ai pas réussi a faire fonctionner le fichier
Est-tu sure qu'il n'y a pas d'erreur ?

Dans l'attente de ton retour,

 

[fanch55]

Petite correction pour effectivement déplacer :

Option Compare Text
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count = 1 Then
        lr = Cells(Rows.Count, "F").End(xlUp).Row
        If Range("F" & Target.Row) Like "terminé" And lr > Target.Row Then
            Application.EnableEvents = False
                Rows(Target.Row).Cut
                Rows(lr + 1).Insert Shift:=xlDown
            Application.EnableEvents = True
        End If
    End If
End Sub

Mais les codes sont bien opérationnels .

 

[oceanepla]

Petite correction pour effectivement déplacer :

Option Compare Text
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count = 1 Then
        lr = Cells(Rows.Count, "F").End(xlUp).Row
        If Range("F" & Target.Row) Like "terminé" And lr > Target.Row Then
            Application.EnableEvents = False
                Rows(Target.Row).Cut
                Rows(lr + 1).Insert Shift:=xlDown
            Application.EnableEvents = True
        End If
    End If
End Sub

Mais les codes sont bien opérationnels .Regarde la pièce jointe 1104784

Je vois bien, mais sur mon fichier, je n'arrive pas. Tu verras les test que j'ai fais sur les pages PA Général et PA DITS. Je ne comprends pas qu'est ce qu'il ne fonctionne pas

 

[fanch55]

Code modifié, Classeur joint modifié, cela devrait fonctionner .

 

[oceanepla]

Code modifié, Classeur joint modifié, cela devrait fonctionner .

Super merci beaucoup cela fonctionne, j'ai encore quelques modification à faire de mon côté

 

[soan]

Bonjour Oceane,

je t'ai écrit ICI.

soan