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

oceanepla · 6 Mai 2021

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 · 6 Mai 2021

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

VB:

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 · 6 Mai 2021

fanch55 à dit:

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

VB:

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 · 6 Mai 2021

Petite correction pour effectivement déplacer :

VB:

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 · 6 Mai 2021

fanch55 à dit:

Petite correction pour effectivement déplacer :

VB:

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 · 6 Mai 2021

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

oceanepla · 7 Mai 2021

fanch55 à dit:
Code modifié, Classeur joint modifié, cela devrait fonctionner .

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

soan · 11 Mai 2021

Bonjour Oceane,

je t'ai écrit ICI.

soan

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

oceanepla

XLDnaute Junior

fanch55

XLDnaute Barbatruc

oceanepla

XLDnaute Junior

fanch55

XLDnaute Barbatruc

oceanepla

XLDnaute Junior

Pièces jointes

fanch55

XLDnaute Barbatruc

Pièces jointes

oceanepla

XLDnaute Junior

soan

XLDnaute Barbatruc

Discussions similaires