Insertion des images sur chaque page en fonction d'une référence

Bonsoir à tous. J'ai besoin de votre aide. J'aimerais pouvoir régénérer les photos des personnes en fonction d'une valeur d'une cellule. J'ai 100 pages et chaque page doit avoir une image qui correspond au nom inscrit dans une cellule et généré par une formule RechercheV. J'avoue que je ne suis pas très apte en VBA. C'est la raison pour laquelle je me tourne vers vous. Merci d'avance

Bonjour et

Un exemple de ce que tu peux avoir :

Une Image/photo en B4 qui aura comme nom la cellule B1 et comme chemin la cellule B2 pour chaque feuille

A+

Bonjour et merci beaucoup pour votre prompte réaction. Je vais essayer tout à l'heure. J'espère que mon problème sera résolu à cette première proposition.

Je n'ai pas réussi à adapter le code. Pour une meilleure compréhension je joins un fichier exemple. Merci

Il faut que tes images soit en ".jpg"

    CheminImage = Sheets(NumF.Name).Range("D11").Value & "\"
    AdresseImage = CheminImage & Sheets(NumF.Name).Range("D9").Value & ".jpg"

Et j'image que les images vont etre en portrait et pas en paysage sinon il faudra inverser les deux lignes :

            .Width = Sheets(NumF.Name).Range("N9:O12").Width - 1
            .Height = Sheets(NumF.Name).Range("N9:O12").Height - 1

A+

Merci

J'ai essayé de généré une autre image portant le nom de la valeur de la cellule D9 mais rien ne se produit. Je ne sais pas pourquoi. Est-ce que vous pouvez placer le code pour que l'image apparaisse de la manière suivante

image en N9:O12 référence en D9 -

N69:O72 pour D69

N129:O132 pour D129

Quand tu dis dans ton premier message :

J'ai 100 pages et chaque page doit avoir une image

Tu as déja 3 images sur ta feuille "Fiche" que je pensais que tu avais 1 image par page / feuille / onglet.
Tes 100 pages donc 100 images vont etre sur ta feuille Fiche ?

Bonjour

les 100 images et 100 pages sont dans le même onglet fiche justement.

Alors il faut changer la macro.
Ca ne correspond pas a mon exemple.

Il y aura toujours 60 lignes de différences entre deux fiches ?
Le lien pour trouver les photo est toujours le meme ?
Les 100 fiches seront toujours sur les colonnes [A:P] ?

Bonsoir Geof et merci pour tous les efforts que vous faites pour m'aider et le génie que vous êtes entrain de déchaîner.

Il n'y aura pas toujours 60 lignes de différence

Le lien peut différer. On peut soit l'introduire dans la macro soit dans une cellule

Les fiches seront toujours dans ces colonnes.

Désolé pour le silence. Trop de boulot. J'ai essayé l'autre macro la première photo s'insère bien mais la deuxième est agrandie.

Je souhaite également que la photo change dès que le nom change et que la précédente photo soit supprimée avant qu'elle ne soit remplacée.

Merci encore

Bonjour Pronzito,

Si il n'y a pas toujours 60 lignes par fiches comment la macro pourra connaitre la cellule "Nom" a utiliser pour trouver la photo ?

Avec ce fichier, chaque fois que tu selectionne le "Nom" (qui sera toujours dans une cellule multiple de 60 ligne +9 ligne) en colonne D
La photo en portant ce "Nom" sera supprimé

Il suffit d'éditer le nom pour que la photo soit mise a jour (si elle existe).
Le "Chemin photo" sera toujours 2 cellules sous le "Nom".

J'ai essayé l'autre macro la première photo s'insère bien mais la deuxième est agrandie.

Surement que le nom que doit porter ta photo a déja été choisi et donc redimensionne pas le bon objet.

Dans ce nouveau fichier commence par lancer la procedure "SuppImage" (dans la feuille 39)

Code Feuille 39 :

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim PicShape As Object
Dim NomPhoto, CheminPhoto, AdresseImage As String
Dim EmplacementPhoto As Range
'Si la ligne qui change est le nom de la photo (ligne selectionné = 9 + multiple de 60 lignes)
If Target.Row Mod 60 = 9 Then
    'Pour chaque image de cette feuille SUPPR
    For Each PicShape In ActiveSheet.Shapes
        If PicShape.Name = Cells(Target.Row, 4).Value Then PicShape.Delete
    Next PicShape
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim PicShape As Object
Dim NomPhoto, CheminPhoto, AdresseImage As String
Dim EmplacementPhoto As Range
'Si la ligne qui change est le nom de la photo (ligne selectionné = 9 + multiple de 60 lignes)
If Target.Row Mod 60 = 9 Then
    'Nom, chemin photo et emplacement de l'image
    NomPhoto = Cells(Target.Row, 4).Value
    CheminPhoto = Cells(Target.Row + 2, 4).Value
    Set EmplacementPhoto = Range(Cells(Target.Row, 14), Cells(Target.Row + 4, 15))
    'AdresseImage
    If Right(CheminPhoto, 1) <> "\" Then CheminPhoto = CheminPhoto & "\"
    AdresseImage = CheminPhoto & NomPhoto & ".jpg"
    'Si l'image existe
    If Dir(AdresseImage) <> "" Then
        Shapes.AddPicture(AdresseImage, False, True, EmplacementPhoto.Left, EmplacementPhoto.Top, -1, -1).Name = NomPhoto
        'Ajuster l'image et la centrer
        With Shapes.Range(Array(NomPhoto))
            .LockAspectRatio = msoTrue
            .Width = EmplacementPhoto.Width - 1
            .Height = EmplacementPhoto.Height - 1
            .Left = EmplacementPhoto.Left + (EmplacementPhoto.Width / 2) - .Width / 2
            .Top = EmplacementPhoto.Top + (EmplacementPhoto.Height / 2) - .Height / 2
        End With
    End If
End If
End Sub

Sub SuppImage()
Dim PicShape As Object
    'Efface toute image de la feuille
    For Each PicShape In ActiveSheet.Shapes
        If PicShape.Type = msoPicture Then PicShape.Delete
    Next PicShape
End Sub

A+

bonjour Pronzito,Geof52,

voici une autre piste avec vos "Fiche3.xlsb"

Option Explicit

Sub PhotoParFeuille()
     Dim CheminImage, AdresseImage As String
     Dim r     As Variant, aA, ext, i, c, c1

     'Dans chaque feuille du classeur
     With Sheets("fiche")                    'pour cette feuille
          .Range("A1:A" & .Range("A" & Rows.Count).End(xlUp).Row).Name = "Col_A"     'la colonne A
          aA = Evaluate("if(col_a =""NOM :"",row(col_a),""~"")")     'numéros des lignes de toutes les cellules ="nom :"
          For i = 1 To UBound(aA)            'boucler toutes ces lignes
               r = Application.Small(aA, i)
               If Not IsNumeric(r) Then Exit For     'on a fait toutes les lignes = exit
               Set c = .Range("D" & r)       'cellule D juste à côté de "NOM"

               CheminImage = c.Offset(2).Value & "\"
               AdresseImage = CheminImage & c.Value
               For Each ext In Array(".BMP", ".jpg", ".Png", ".IMG")     'extensions possible
                    'Si l'image existe
                    If Dir(AdresseImage & ext) <> "" Then
                         Set c1 = c.Offset(, 9).Resize(4, 3)     'endroit de l'image
                         'c1.Interior.ColorIndex = 3
                         With .Shapes.AddPicture(AdresseImage & ext, False, True, c1.Left, c1.Top, -1, -1)
                              .Name = c.Value
                              .LockAspectRatio = msoTrue
                              .Width = c1.Width - 1
                              .Height = c1.Resize(4).Height - 1
                              .Left = c1.Left + (c1.Width - .Width) / 2
                              .Top = c1.Top + (c1.Height - .Height) / 2
                         End With
                         Exit For
                    End If
               Next
          Next
     End With
End Sub

Bonjour et merci beaucoup d'avance

Je la teste tout à l'heure dès que je suis devant la machine. Autre chose avant de le faire c'est de savoir comment la macro sera lancée. Est-ce que c'est automatique c'est-à-dire une fois que le nom change ou alors grâce à un bouton ? Il est vrai que je souhaite vivement que le changement de fasse automatiquement.

cordialement

Bonjour Pronzito,BsAlv,

Pour les procedures de mon dernier code,

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'... Se lance en selectionnant une cellule
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
'... Se lance quand on a édité une cellule
End Sub

Sub SuppImage()
'... pas de lancement automatique
End Sub

Les deux premieres procedures sont des procedures evenementielles (placées dans la feuille et qui vont donc s'activer automatiquement suivant certaines action)
Pour la troisieme il faudra un bouton comme toutes les autres procedure de ce fil.

re,

ma macro ne se lance pas automatiquement, mais avec un petit effort, cela est possible.

Geof

J'ai encore essayé ton code ci, que je comprends plus facilement. Ce qui pose problème c'est la suppression automatique de l'ancienne photo et l'insertion de celle qui correspond au nouveau nom inscrit dans une cellule. Il y a aussi le lancement de la macro (automatiquement ou par un bouton)

Il faut prendre le dernier fichier "fiche4.xlsb" car dans le 3, :

- je n'avais pas encore compris que tu n'avais qu'une feuille de 100 fiches
- il n'y avait pas encore la demande de rendre l'execution des procedures automatique.
- Pas de mise a jour d'image juste de l'ajout d'image

La fiche 4 a la même logique de programmation que le 3.
Tu devrais le comprendre aussi bien puisque les variables sont "explicite" enfin je crois.

Je viens de tester cette macro. Elle est formidable. Seulement l'ancienne photo ne se supprime pas avant l'insertion de la nouvelle. En plus si je veux mettre le chemin d'accès à L9 par exemple que faut-il écrire dans le code ?

la macro de suppression enlève toutes les images y compris le logo.

Autre chose j'espère que je ne dérange pas. Je me rends compte que la photo se met à jour seulement lorsqu'on change le contenu de la cellule du nom. Est-ce qu'on peut générer les photos grâce à un bouton ou sans avoir besoin de modifier la cellule car les noms sont générés par une formule recherchev

Seulement l'ancienne photo ne se supprime pas avant l'insertion de la nouvelle.

la macro de suppression enlève toutes les images y compris le logo.

Si tu lance "Sub SuppImage()", oui toutes les photos se supprime
Mais si tu selectionne la cellule D9, il y a seulement l'image nommé avec le nom inscrit dans la cellule D9 (donc l'image en N9) sera supprimé grace a "Private Sub Worksheet_SelectionChange(ByVal Target As Range)".

si je veux mettre le chemin d'accès à L9 par exemple que faut-il écrire dans le code ?

Il faut modifier le CheminPhoto dans la macro

    CheminPhoto = Cells(Target.Row + 2, 4).Value
'Correspond a le ligne "Nom" +2 et colonne 4 donc D11

    CheminPhoto = Cells(Target.Row, 12).Value
'Correspond a le ligne "Nom" et colonne 12 donc L9

Est-ce qu'on peut générer les photos grâce à un bouton

Oui tu ajoute cette procedure : (Le CheminPhoto sera en D11)

Sub PhotoParFeuille()
Dim NomPhoto, CheminPhoto, AdresseImage As String
Dim EmplacementPhoto As Range
Dim Ligne, DerLigne As Integer
'Pour les lignes de 9 a la derniere ligne de la colonne D (toutes les 60 lignes)
DerLigne = Cells(Rows.Count, 4).End(xlUp).Row
For Ligne = 9 To DerLigne Step 60
    If Ligne Mod 60 = 9 Then
        'Nom, chemin photo et emplacement de l'image
        NomPhoto = Cells(Ligne, 4).Value
        CheminPhoto = Cells(Ligne + 2, 4).Value
        Set EmplacementPhoto = Range(Cells(Ligne, 14), Cells(Ligne + 4, 15))
        'AdresseImage
        If Right(CheminPhoto, 1) <> "\" Then CheminPhoto = CheminPhoto & "\"
        AdresseImage = CheminPhoto & NomPhoto & ".jpg"
        'Si l'image existe
        If Dir(AdresseImage) <> "" Then
            ActiveSheet.Shapes.AddPicture(AdresseImage, False, True, EmplacementPhoto.Left, EmplacementPhoto.Top, -1, -1).Name = NomPhoto
            'Ajuster l'image et la centrer
            With ActiveSheet.Shapes.Range(Array(NomPhoto))
                .LockAspectRatio = msoTrue
                .Width = EmplacementPhoto.Width - 1
                .Height = EmplacementPhoto.Height - 1
                .Left = EmplacementPhoto.Left + (EmplacementPhoto.Width / 2) - .Width / 2
                .Top = EmplacementPhoto.Top + (EmplacementPhoto.Height / 2) - .Height / 2
            End With
        End If
    End If
Next
End Sub

Et pour un chemin en L9:

CheminPhoto = Cells(Ligne, 12).Value

A+