Sub trier()
Dim P As Range, t1, t2, d As Object, cible As Range, o As Object, a, i%, nom$
Set P = Feuil1.[A1:A147] 'à adapter
t1 = P 'matrice, plus rapide
t2 = Feuil2.[K2:K214] 'à adapter
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(t2)
d(t2(i, 1)) = ""
Next
For i = 1 To UBound(t1)
If Not d.exists(t1(i, 1)) Then t1(i, 1) = ""
Next
P = t1
'---copie l'image---
Application.CopyObjectsWithCells = True 'si nécessaire
Application.ScreenUpdating = False
With Feuil3 'CodeName de la feuille
Set cible = .[A2].MergeArea
cible.Clear 'efface tout, y compris la fusion
On Error Resume Next 'si l'image n'existe pas
.Shapes("MaJolieShape").Delete
On Error GoTo 0
For Each o In .DrawingObjects
If Not Intersect(o.TopLeftCell, .[L2:N2]) Is Nothing Then
a = Split(o.TopLeftCell, vbLf)
For i = 0 To UBound(a)
If Application.CountIf(P, Trim(a(i))) Then
nom = o.Name 'mémorise le nom
o.Name = "MaJolieShape"
o.TopLeftCell.Copy cible(1)
o.Name = nom
cible.Merge
cible(1) = o.TopLeftCell 'si formule
'---cadrage---
Set o = .Shapes("MaJolieShape")
o.Left = cible.Left + (cible.Width - o.Width) / 2
Exit Sub
End If
Next
End If
Next
cible.Merge
End With
End Sub