Couper/Coller avec Condition

Bsr

J'ai des données qu'il faut couper et coller vers la cellule qui se trouve à droite.

(Ces données sont initialement en ligne et mise en colonne à partir d'un code)

J'ai écris le code ci-après mais je ne trouve pas l'erreur.

j'ai joins une exemple, le problème se trouve dans la feuil2

Sub coupercoller()

    Dim LastRow As Long
    Dim cel As Range

    LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

    Set plage1 = Sheets("BD").Range("H:H")
        For Each cel In plage1

            If cel.Value Like "*" & "motclé" & "*" Then cel.Copy
            ActiveCell.Offset(0, 1).Select
            ActiveCell.Paste
        Application.CutCopyMode = False
        Next cel

End Sub

Merci d'avance de votre aide.

bonjour,

proposition de correction

Sub coupercoller()

    Dim LastRow As Long
    Dim cel As Range

    LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    motclé = "Info2"
    Set plage1 = Sheets("feuil2").Range("H2:H" & LastRow)
        For Each cel In plage1
            If cel.Value Like "*" & motclé & "*" Then cel.Offset(, 1) = cel
        Next cel
End Sub

Merci, je vais l'essayer tout de suite!

Le code ne prend pas en compte le "motclé" et copie juste tout les cellules de la rangée H au rangée I