Copier les motifs et le remplissage des rectangles

Bonjour,

J'aimerais créer un macro qui me permettrais de copier le motifs et le remplissage du rectangle portant le nom "FF" à tous les rectangles qui contienne le mot "Argile".

j'ai essayé de créer la macro moi même sans grande réussite :

Sub CopierMotifRemplissage()

Dim cell As Range
Dim shp As Shape

'Récupérer le motif de remplissage de la forme "FF"
Dim motif As Integer
motif = Sheets("Feuil1").Shapes("FF").Fill.Pattern

'Parcourir toutes les cellules de la feuille
For Each cell In Sheets("Feuil1").UsedRange.Cells

'Vérifier si la cellule contient le mot "argile" et si elle contient des formes
If InStr(1, cell.Value, "argile", vbTextCompare) > 0 And cell.Shapes.Count > 0 Then

'Parcourir toutes les formes de la cellule
For Each shp In cell.Shapes

'Vérifier si la forme contient le mot "argile" et si elle est remplie avec un motif
If InStr(1, shp.TextFrame.Characters.Text, "argile", vbTextCompare) > 0 And shp.Fill.Type = msoPatterned Then

'Copier le motif de remplissage de la forme "FF" vers la forme de la cellule actuelle
shp.Fill.Pattern = motif

End If

Next shp

End If

Next cell

End Sub

Merci d'avance pour votre retour,

Charles

Hello,

A tester

    Dim sh As Shape
    On Error Resume Next
    For Each sh In Worksheets(1).Shapes
        If sh.Type = 1 Then 'Si rectange
                If LCase(sh.TextFrame2.TextRange.Characters.Text) Like "*argile*" Then
                    Worksheets(1).Shapes("FF").PickUp
                    sh.Apply
                End If
        Else: 'Rien à faire
        End If
    Next sh

ça fonctionne

Merci !