Copier/Coller cellule contenant

Bonjour à tous,

Je dispose d'un tableau d'environ 500 lignes contenant une seule colonne nommée "Nom"

Cette colonne contient un code par cellule sous la forme "123PO", "489ML", 758AP", etc.

En dessous de chaque cellule contenant un code se trouve une cellule vide.

Je souhaiterais comparer ces codes à un bigramme par exemple "PO".

Si le code contient ce bigramme alors il faudrait copier le code et le coller dans la cellule vide juste en dessous.

Exemple : si la cellule A1=123PO alors coller 123PO dans la cellule A2 car A1 contient "PO".

Débutant en programmation, j'ai fait des recherches sur le net et élaboré un premier code mais il ne fonctionne pas.

Quelqu'un pourrait-il m'aider là-dessus?

Par avance, merci.

Sub test()
Dim LigneFin As Integer, Ligne As Integer, Trouvé As Range

    Set Start = ActiveWorkbook.ActiveSheet.Cells.Find("nom")
    Start.Select

    LigneFin = Start.Offset(10000).End(xlUp).Row
    Ligne = Start.Row + 1
    While intLigne <= intLigneFin

        Set Trouvé = ThisWorkbook.ActiveSheet. _
                Cells.Find(ActiveWorkbook.ActiveSheet.Cells(Ligne, Start.Column).Value)
        If Trouvé Like "*po*" Then
                Trouvé.Offset(1, 0).Value = Trouvé.Value

        End If

        intLigne = intLigne + 1
    Wend

End Sub

Bonjour, la méthode find est bien mais parfois elle est casse *biiiiiip*.

je vous propose une autre solution :

La macro lis les cellules une à une et si elle trouve PO elle copie la cellule en dessous.

Sub macro()
    Dim dl&, i%
    dl = Feuil1.Range("a" & Rows.Count).End(xlUp).Row

    With Feuil1
        For i = dl To 2 Step -1
            If InStr(1, .Cells(i, 1), "PO", vbTextCompare) Then
                .Cells(i, 1).Copy .Cells(i + 1, 1)
            End If
        Next
    End With
End Sub

Merci beaucoup force rouge! Tu m'a permis de gagner plusieurs heures de travail !

Bonne soirée, merci.

Pareillement