Faire apparaitre une photo

Bonjour

Dans le fichier ci joint feuil photo j'ai des nom et des images

feuil liste j'ai des noms ,je cherche à faire apparaitre les images selon les noms

j'ai un code vba mais cela ne fonctionne pas

Merci pour votre aide

Sub AfficherPhotos()
    Dim wsPhoto As Worksheet
    Dim wsListe As Worksheet
    Dim nom As String
    Dim cheminPhoto As String
    Dim cell As Range
    Dim photo As Picture

    ' Définir les feuilles
    Set wsPhoto = ThisWorkbook.Sheets("Photo")
    Set wsListe = ThisWorkbook.Sheets("Liste")

    ' Boucle à travers chaque nom dans la feuille Liste
    For Each cell In wsListe.Range("A2:A" & wsListe.Cells(wsListe.Rows.Count, "A").End(xlUp).Row)
        nom = cell.Value

        ' Chercher le nom dans la feuille Photo
        On Error Resume Next
        cheminPhoto = wsPhoto.Range("A:A").Find(nom, LookIn:=xlValues, LookAt:=xlWhole).Offset(0, 1).Value
        On Error GoTo 0

        ' Si une photo correspondante est trouvée, l'insérer
        If cheminPhoto <> "" Then
            Set photo = wsListe.Pictures.Insert(cheminPhoto)
            With photo
                .Left = cell.Offset(0, 1).Left
                .Top = cell.Top
                .Width = 100 ' Ajustez la largeur selon vos besoins
                .Height = 100 ' Ajustez la hauteur selon vos besoins
            End With
        End If
    Next cell
End Sub

Bonjour,

Essayez ceci:

le fichier:

le code:

Sub AfficherPhotos()
    Dim wsPhoto As Worksheet
    Dim wsListe As Worksheet
    Dim nom As String
    Dim cheminPhoto As Object
    Dim cell As Range

    ' Définir les feuilles
    Set wsPhoto = ThisWorkbook.Sheets("Photo")
    Set wsListe = ThisWorkbook.Sheets("Liste")

    'Effacer toutes les images existantes dans la feuille"Liste"
    wsListe.DrawingObjects.Delete

    ' Boucle à travers chaque nom dans la feuille Liste
    For Each cell In wsListe.Range("A2:A" & wsListe.Cells(wsListe.Rows.Count, "A").End(xlUp).Row)
        nom = cell.Value

        ' Chercher le nom dans la feuille Photo
        With wsPhoto.Range("A:A")
            Set cheminPhoto = .Find(nom, LookIn:=xlValues, LookAt:=xlWhole)
            If Not cheminPhoto Is Nothing Then
                wsPhoto.Shapes(cheminPhoto).Copy 'on copie l'image
                wsListe.Paste wsListe.Cells(Cells.Row, "B") 'on colle l'image
                With wsListe.Shapes.Range(Array(cheminPhoto))
                    .Left = wsListe.Cells(cell.Row, "B").Left
                    .Top = wsListe.Cells(cell.Row, "B").Top
                    .Width = wsListe.Cells(cell.Row, "B").Width ' Ajustez la largeur selon vos besoins
                    .Height = wsListe.Cells(cell.Row, "B").Height ' Ajustez la hauteur selon vos besoins
                End With
            End If
        End With
    Next cell
End Sub

Cdlt

Bonsoir,

une proposition sans avoir besoin de renommer les images, mais il faudra tout de même qu'elles aient un nom différents...

Sub LouReeD()
    Dim Ligne As Long, ShC As Shape, Sh As Shape, NbPhoto As Long, Cel As Range, I As Long
    For Each Sh In ActiveSheet.Shapes
        If Sh.Name <> "Allons_y" Then Sh.Delete
    Next
    NbLigne = Sheets("liste").Cells(Sheets("Liste").Rows.Count, "A").End(xlUp).Row
    NbPhoto = Sheets("Photo").Cells(Sheets("Photo").Rows.Count, "A").End(xlUp).Row
    For I = 1 To NbLigne
        Set Cel = Sheets("Photo").Range("A1:A" & NbPhoto).Find(Cells(I, 1))
        If Not Cel Is Nothing Then
            ' on boucle sur les shapes afin de trouver celui qui correspond à la colonne B de la ligne trouvée
            For Each Sh In Sheets("Photo").Shapes
                ' s'il y a la même adresse entre le point haut gauche du shape et la cellule colonne B
                If Sh.TopLeftCell.Address = Cel.Offset(, 1).Address Then
                    ' on duplique l'image
                    Set ShC = Sheets("Photo").Shapes(Sh.Name).Duplicate
                    ' on force le nom
                    ShC.Name = Sh.Name
                    ' on la coupe
                    ShC.Cut
                    ' on la colle en colonne B
                    Sheets("Liste").Paste Sheets("liste").Cells(I, 2)
                    ' avec ce collage
                    With Sheets("liste").Shapes(Sh.Name)
                        ' on réduit sa hauteur de 4
                        .Height = Cells(I, 2).Height - 4
                        ' on centre en largeur de cellule
                        .Left = Cells(I, 2).Left + ((Cells(I, 2).Width - .Width) / 2)
                        ' on centre en hauteur
                        .Top = Cells(I, 2).Top + 2
                    End With
                    ' on a trouvé l'image du nom on sort prématurément de la boucle de recherche
                    Exit For
                End If
            Next
        End If
    Next I
    Range("A1").Select
End Sub

@ bientôt

LouReeD

Bonjour

Merci pour votre aide

Crdlt

Bonsoir,

merci pour ce retour et vos remerciements !

@ bientôt

LouReeD