Couper/coller des lignes sur une même feuille sous condition de couleur

Bonjour le forum,

En espérant que le titre attire les meilleurs d'entre vous afin de m'aider, voici mon problème :

Afin de réaliser rapidement un rapport, éviter les couper/coller à la main je souhaiterai créer une macro qui regarde si une case est de couleur jaune, si oui elle la coupe et la déplace plus haut dans la feuille. Ainsi de suite pour chaque case jaune jusqu'à la rencontre d'une case noir.

Sauf que ces cellules jaune ne se trouve dans la colonne A et à partir de la ligne 52.

Il faudrait que toute la ligne contenant une cellule jaune à partir de la cellule A52 soit couper/coller à la ligne 45, 46 , 47 etc.

Je vous joint mon fichier qui je l'espère vous aidera à mieux comprendre...

Merci d'avance à toutes et à tous !!

Bonjour

Je ne suis pas sûre que cela convienne à cause des lignes fusionnées, mais c'est à voir

Sub deplacer_jaune()
    Set ws = Sheets("rapport PP1")
    dlig = ws.Range("A:A").Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lighaut = 45
    For i = 52 To dlig
        If ws.Cells(i, 1).Interior.ColorIndex = 1 Then
            Exit For
        End If
        If ws.Cells(i, 1).Interior.ColorIndex = 6 Then
            ws.Rows(i).Cut Destination:=ws.Rows(lighaut)
            lighaut = lighaut + 1
        End If
    Next
End Sub

Dis-moi

A+

Salut Patty,

Déjà merci,

Ensuite c'est un bon début car les lignes contenant les cases jaunes se déplacent en haut mais... elles remplacent les lignes existantes donc en effet c'est pas ce que je recherche :/

Est-il possible que les lignes soit insérées et non juste copiées ?

Bonjour

Sub deplacer_jaune()
    ' 6  coul = Cells(54, 1).Interior.ColorIndex
    '  1  coul = Cells(89, 1).Interior.ColorIndex
    Set ws = Sheets("rapport PP1")
    dlig = ws.Range("A:A").Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lighaut = 45
    For i = 52 To dlig
        If ws.Cells(i, 1).Interior.ColorIndex = 1 Then
            Exit For
        End If
        If ws.Cells(i, 1).Interior.ColorIndex = 6 Then
            ws.Rows(i).Cut
            ws.Rows(lighaut).Select
            Selection.Insert Shift:=xlDown
            lighaut = lighaut + 1
        End If
    Next
End Sub

Mea culpa

Bye