Copie de photos d'une feuille à une autre en fonction de données

Le 08/05/2025 à 17:22

Bonjour à tous,

J'aurais besoin qu'on m'aide à concevoir un code VBA afin de copier des photos d'une feuille à une autre en fonction de données sélectionnées à partir d'un menu déroulant.

Dans le fichier " Catalogue_equipement_1.xlsb" ci-joint, j'ai une feuille "Données" contenant toutes les informations pertinentes sur un appareil. Dans les colonnes 52, 53 54 et 55, des photos (exemple) de chacun des appareils sont présentes. J'ai également une feuille "Fiche" qui permet d'afficher les données présentes dans la feuille "Données".

Exemple n° 1 : dans le menu déroulant, quand je sélectionne "Aérotherme électrique", je veux que les photos situées dans les cellules "AZ6", "BA6", "BB6" et "BC6", se collent dans les espaces prévus dans la feuille "Fiche" (voir rectangle). Exemple n° 2 : dans le menu déroulant, quand je sélectionne " Aéroconvecteur électrique (porte d'entrée)", je veux que les photos situées dans les cellules "AZ5", "BA5", "BB5" et "BC5", se collent dans les espaces prévus dans la feuille "Fiche" et ainsi de suite.

Si vous désirez des précisions additionnelles, n'hésitez pas à me contacter.

En vous remerciant par avance pour votre précieuse aide.

Salutations,

Renaud D.

22catalogue-equipement-1.zip (1.27 Mo)
Le 09/05/2025 à 06:29

Bonjour,

Les images de la feuille "Données" ont été renommées de la façon suivante: "Image_" suivi du code et d'un numéro allant de 1 à 4 exemple pour les images du code ACEP: "Image_ACEP1", "ImageçACEP2", "ImageçACEP3", "ImageçACEP4", même principe pour les autres lignes.

Pour renommer une image, clic droit sur l'image puis, dans la zone de nom(à gauche de la ligne des formules) saisir le nouveau nom et valider avec la touche "ENTREE"

A chaque changement de l'équipement dans la feuille fiche, les photos sont rapatriées dans la foulée.

14renaud-dugas-copie-de-photos-d-une-feuille-a-une-autre-en-fonction-de-donnees.zip (1.27 Mo)

Cdlt

Le 09/05/2025 à 16:57

Bonjour Arturo83,

Merci d'avoir répondu à ma demande d'aide. Votre code fonctionne parfaitement avec 4 images. Cependant, serait-il possible de l'adapter afin qu'il puisse tenir compte de la possibilité d'avoir aucune image, 1 seule image (colonne 52), 2 images (colonnes 52 & 53), 3 images (colonnes 52, 53 & 54) ou 4 images (colonnes 52, 53, 54 & 55)?

Dans l'attente de votre réponse,

Salutations,

Renaud D.

Le 09/05/2025 à 21:14

Bonsoir Renaud Dugas, Arturo83

Peut-être un truc comme ça!

Public Eqt As String

Sub AfficherPhotos()
    Dim f1 As Worksheet, f2 As Worksheet
    Dim LigPhoto As Object
    Dim cell As Range
    Dim shpName As String
    Dim shp As Shape
    Dim i As Integer

    ' Définir les feuilles
    Set f1 = ThisWorkbook.Sheets("Fiche")
    Set f2 = ThisWorkbook.Sheets("Données")
    f1.Activate

    ' Effacer toutes les images existantes dans la feuille "Fiche"
    On Error Resume Next
    For Each shp In f1.Shapes
        If Left(shp.Name, 6) = "Image_" Then shp.Delete
    Next
    On Error GoTo 0

    ' Chercher le Eqt dans la feuille Données
    With f2.Range("B:B")
        Set LigPhoto = .Find(Eqt, LookIn:=xlValues, LookAt:=xlWhole)

        If Not LigPhoto Is Nothing Then
            Dim CodeEqt As String
            CodeEqt = f2.Cells(LigPhoto.Row, "J")

            For i = 1 To 4
                shpName = "Image_" & CodeEqt & i
                On Error Resume Next
                Set shp = f2.Shapes(shpName)
                On Error GoTo 0

                If Not shp Is Nothing Then
                    shp.Copy
                    f1.Activate

                    Select Case i
                        Case 1
                            f1.Paste f1.Cells(5, "J")
                            With f1.Shapes(f1.Shapes.Count)
                                .Name = shpName
                                .Left = f1.Range("J5:J14").Left
                                .Top = f1.Range("J5:J14").Top
                                .Width = f1.Range("J5:J14").Width
                                .Height = f1.Range("J5:J14").Height
                            End With
                        Case 2
                            f1.Paste f1.Cells(5, "L")
                            With f1.Shapes(f1.Shapes.Count)
                                .Name = shpName
                                .Left = f1.Range("L5:L14").Left
                                .Top = f1.Range("L5:L14").Top
                                .Width = f1.Range("L5:L14").Width
                                .Height = f1.Range("L5:L14").Height
                            End With
                        Case 3
                            f1.Paste f1.Cells(16, "J")
                            With f1.Shapes(f1.Shapes.Count)
                                .Name = shpName
                                .Left = f1.Range("J16:J24").Left
                                .Top = f1.Range("J16:J24").Top
                                .Width = f1.Range("J16:J24").Width
                                .Height = f1.Range("J16:J24").Height
                            End With
                        Case 4
                            f1.Paste f1.Cells(16, "L")
                            With f1.Shapes(f1.Shapes.Count)
                                .Name = shpName
                                .Left = f1.Range("L16:L24").Left
                                .Top = f1.Range("L16:L24").Top
                                .Width = f1.Range("L16:L24").Width
                                .Height = f1.Range("L16:L24").Height
                            End With
                    End Select
                End If
                Set shp = Nothing
            Next i
        End If
    End With

    f1.Range("A1").Select
End Sub

Slts

Le 09/05/2025 à 22:18

Bonsoir Arturo83,

J'ai inséré votre code au fichier initial (voir Catalogue_equipement_2.xlsb ci-joint) mais cela ne fonctionne pas.

J'ai peut-être fait une erreur. Pourriez-vous, svp, le corriger et me le renvoyer.

Salutations,

Renaud D.

9catalogue-equipement-2.zip (1.27 Mo)
Le 09/05/2025 à 23:13

Re Renaud Dugas

Bonsoir Arturo83

Attention ce n'est pas Arturo83 mais Boss_68 qui t'a proposé ce code modifié
j'ai tester chez moi le retour de ton fichier et ton fichier est fonctionnel chez moi, je suppose que cela provient du fait que tu travailles en excel 2007

Essai à tout hasard celui-là

9catalogue-equipement-2.zip (1.27 Mo)

Slts

Le 09/05/2025 à 23:35

Bonsoir boss_68,

Désolé, je n'ai pas fait attention. Excusez mon erreur.

J'ai testé votre code dans le dernier fichier transmis, mais malheureusement, ça ne fonctionne pas.

Comme vous dites, cela est être probablement causé par ma version d'Excel (2007).

Salutations,

Renaud D.

Le 10/05/2025 à 07:04

Bonjour,

Voici ce que vous demandez. Attention, les photos dans la feuille "Données" doivent bien être incluses dans les cellules sans déborder sur les cellules du dessus ou du dessous, sinon elles ne seront pas prises en compte.

12renaud-dugas-copie-de-photos-d-une-feuille-a-une-autre-en-fonction-de-donnees-1.zip (1.28 Mo)

le code modifié:

Public Eqt As String
Sub Agrandissement_Image()
Dim Sh As Shape
Dim Ligne As Long, Colonne As Integer

  Set Sh = ActiveSheet.Shapes(Application.Caller)
  Ligne = Sh.TopLeftCell.Row
  Colonne = Sh.TopLeftCell.Column
  ActiveSheet.Shapes(Application.Caller).ZOrder msoBringToFront
  With ActiveSheet.Shapes(Application.Caller)
    If .AlternativeText = "" Then
      .ScaleWidth 0.5, msoFalse, msoScaleFromTopLeft
      .ScaleHeight 0.5, msoFalse, msoScaleFromTopLeft
      .AlternativeText = "zoom"
    Else
      ActiveWindow.ScrollColumn = Colonne - 5
      ActiveWindow.ScrollRow = Ligne - 4
      .ScaleWidth 2, msoFalse, msoScaleFromTopLeft
      .ScaleHeight 2, msoFalse, msoScaleFromTopLeft
      .AlternativeText = ""
    End If
  End With
  Range("A1").Select
End Sub

Sub AfficherPhotos()
    Dim f1 As Worksheet, f2 As Worksheet
    Dim LigPhoto As Object
    Dim cell As Range
    Dim Compteur As Long
    Dim Photo As Shape
    Dim HautLig As Double, BasLig As Double

    Application.ScreenUpdating = False
    ' Définir les feuilles
    Set f1 = ThisWorkbook.Sheets("Fiche")
    Set f2 = ThisWorkbook.Sheets("Données")
    f1.Activate
    'Effacer toutes les images existantes dans la feuille"Liste"
    On Error GoTo Suite
    For Each img In ActiveSheet.Shapes
        If Left(img.Name, 6) = "Image_" Then img.Delete
    Next

Suite:
    ' Chercher le Eqt dans la feuille Photo
    f2.Activate
    With f2.Range("B:B")
        Set LigPhoto = .Find(Eqt, LookIn:=xlValues, LookAt:=xlWhole)
        CodeEqt = f2.Cells(LigPhoto.Row, "J")
        With ActiveSheet
            'on ne prend en compte que les photos qui sont comprise dans la ligne testée
           HautLig = .Rows(LigPhoto.Row).Top
           BasLig = HautLig + .Rows(LigPhoto.Row).Height

           For Each Photo In .Shapes
               ' on vérifie si les photos sont entièrement positionnées dans la ligne testée pour ne compter que ces dernières
               If Photo.Top >= HautLig And (Photo.Top + Photo.Height) <= BasLig Then
                   Compteur = Compteur + 1
               End If
           Next Photo
        End With

        If Compteur > 0 Then
            'Récupération de la liste des photos de cette ligne
            f2.Select
            If Not LigPhoto Is Nothing Then
                For i = 1 To Compteur
                    With f2.Range(f2.Cells(LigPhoto.Row, "AZ"), f2.Cells(LigPhoto.Row, "BC"))
                        Select Case i
                            Case 1
                                f2.Shapes("Image_" & CodeEqt & i).Copy 'on copie l'image
                                f1.Activate
                                f1.Paste f1.Cells(5, "J") 'on colle l'image
                                With f1.Shapes.Range(Array("Image_" & CodeEqt & i))
                                    .Left = Range(f1.Cells(5, "J"), f1.Cells(14, "J")).Left
                                    .Top = Range(f1.Cells(5, "J"), f1.Cells(14, "J")).Top
                                    .Width = Range(f1.Cells(5, "J"), f1.Cells(14, "J")).Width
                                    .Height = Range(f1.Cells(5, "J"), f1.Cells(14, "J")).Height
                                End With
                            Case 2
                                f2.Shapes("Image_" & CodeEqt & i).Copy 'on copie l'image
                                f1.Activate
                                f1.Paste Range(f1.Cells(5, "L")) 'on colle l'image
                                With f1.Shapes.Range(Array("Image_" & CodeEqt & i))
                                    .Left = Range(f1.Cells(5, "L"), f1.Cells(14, "L")).Left
                                    .Top = Range(f1.Cells(5, "L"), f1.Cells(14, "L")).Top
                                    .Width = Range(f1.Cells(5, "L"), f1.Cells(14, "L")).Width
                                    .Height = Range(f1.Cells(5, "L"), f1.Cells(14, "L")).Height
                                End With
                            Case 3
                                f2.Shapes("Image_" & CodeEqt & i).Copy 'on copie l'image
                                f1.Activate
                                f1.Paste Range(f1.Cells(16, "J")) 'on colle l'image
                                With f1.Shapes.Range(Array("Image_" & CodeEqt & i))
                                   .Left = Range(f1.Cells(16, "J"), f1.Cells(24, "J")).Left
                                   .Top = Range(f1.Cells(16, "J"), f1.Cells(24, "J")).Top
                                   .Width = Range(f1.Cells(16, "J"), f1.Cells(24, "J")).Width
                                   .Height = Range(f1.Cells(16, "J"), f1.Cells(24, "J")).Height
                                End With
                           Case 4
                                f2.Shapes("Image_" & CodeEqt & i).Copy 'on copie l'image
                                f1.Activate
                                f1.Paste Range(f1.Cells(16, "L")) 'on colle l'image
                                With f1.Shapes.Range(Array("Image_" & CodeEqt & i))
                                   .Left = Range(f1.Cells(16, "L"), f1.Cells(24, "L")).Left
                                   .Top = Range(f1.Cells(16, "L"), f1.Cells(24, "L")).Top
                                   .Width = Range(f1.Cells(16, "L"), f1.Cells(24, "L")).Width
                                   .Height = Range(f1.Cells(16, "L"), f1.Cells(24, "L")).Height
                                End With
                            End Select
                    End With
                Next i
            End If
        End If
    End With
    f1.Range("J7").Select
End Sub

Cdlt

Edit: autre version plus courte:

Public Eqt As String

Sub Agrandissement_Image()
Dim Sh As Shape
Dim Ligne As Long, Colonne As Integer

  Set Sh = ActiveSheet.Shapes(Application.Caller)
  Ligne = Sh.TopLeftCell.Row
  Colonne = Sh.TopLeftCell.Column
  ActiveSheet.Shapes(Application.Caller).ZOrder msoBringToFront
  With ActiveSheet.Shapes(Application.Caller)
    If .AlternativeText = "" Then
      .ScaleWidth 0.5, msoFalse, msoScaleFromTopLeft
      .ScaleHeight 0.5, msoFalse, msoScaleFromTopLeft
      .AlternativeText = "zoom"
    Else
      ActiveWindow.ScrollColumn = Colonne - 5
      ActiveWindow.ScrollRow = Ligne - 4
      .ScaleWidth 2, msoFalse, msoScaleFromTopLeft
      .ScaleHeight 2, msoFalse, msoScaleFromTopLeft
      .AlternativeText = ""
    End If
  End With
  Range("A1").Select
End Sub

Sub AfficherPhotos()
    Dim f1 As Worksheet, f2 As Worksheet
    Dim LigPhoto As Object
    Dim cell As Range
    Dim Compteur As Long
    Dim Photo As Shape
    Dim HautLig As Double, BasLig As Double
    Dim Plage_Dest As String

    Application.ScreenUpdating = False
    ' Définir les feuilles
    Set f1 = ThisWorkbook.Sheets("Fiche")
    Set f2 = ThisWorkbook.Sheets("Données")
    f1.Activate
    'Effacer toutes les images existantes dans la feuille"Liste"
    On Error GoTo Suite
    For Each Photo In ActiveSheet.Shapes
        If Left(Photo.Name, 6) = "Image_" Then img.Delete
    Next

Suite:
    ' Chercher le Eqt dans la feuille Photo
    f2.Activate
    With f2.Range("B:B")
        Set LigPhoto = .Find(Eqt, LookIn:=xlValues, LookAt:=xlWhole)
        CodeEqt = f2.Cells(LigPhoto.Row, "J")
        With ActiveSheet
            'on ne prend en compte que les photos qui sont comprise dans la ligne testée
           HautLig = .Rows(LigPhoto.Row).Top
           BasLig = HautLig + .Rows(LigPhoto.Row).Height

           For Each Photo In .Shapes
               ' on vérifie si les photos sont entièrement positionnées dans la ligne testée pour ne compter que ces dernières
               If Photo.Top >= HautLig And (Photo.Top + Photo.Height) <= BasLig Then
                   Compteur = Compteur + 1
               End If
           Next Photo
        End With

        If Compteur > 0 Then
            'Récupération de la liste des photos de cette ligne
            f2.Select
            If Not LigPhoto Is Nothing Then
                For i = 1 To Compteur
                    With f2.Range(f2.Cells(LigPhoto.Row, "AZ"), f2.Cells(LigPhoto.Row, "BC"))
                        Select Case i
                            Case 1
                                Plage_Dest = Range(f1.Cells(5, "J"), f1.Cells(14, "J")).Address
                                f2.Shapes("Image_" & CodeEqt & i).Copy 'on copie la photo
                                f1.Activate
                                f1.Paste f1.Cells(5, "J") 'on colle la photo
                            Case 2
                                Plage_Dest = Range(f1.Cells(5, "L"), f1.Cells(14, "L")).Address
                                f2.Shapes("Image_" & CodeEqt & i).Copy 'on copie la photo
                                f1.Activate
                                f1.Paste Range(f1.Cells(5, "L")) 'on colle la photo
                            Case 3
                                Plage_Dest = Range(f1.Cells(16, "J"), f1.Cells(24, "J")).Address
                                f2.Shapes("Image_" & CodeEqt & i).Copy 'on copie la photo
                                f1.Activate
                                f1.Paste Range(f1.Cells(16, "J")) 'on colle la photo
                           Case 4
                                Plage_Dest = Range(f1.Cells(16, "L"), f1.Cells(24, "L")).Address
                                f2.Shapes("Image_" & CodeEqt & i).Copy 'on copie la photo
                                f1.Activate
                                f1.Paste Range(f1.Cells(16, "L")) 'on colle la photo
                            End Select
                            With f1.Shapes.Range(Array("Image_" & CodeEqt & i))
                               .Left = f1.Range(Plage_Dest).Left
                               .Top = f1.Range(Plage_Dest).Top
                               .Width = f1.Range(Plage_Dest).Width
                               .Height = f1.Range(Plage_Dest).Height
                            End With
                    End With
                Next i
            End If
        End If
    End With
    f1.Range("J7").Select
End Sub
Le 10/05/2025 à 10:16

Bonjour,

Une autre proposition qui ne demande pas de renommer les images, la seule condition :le coin supérieur gauche de l'image doit être sur la ligne de l'équipement même si l'image déborde de la cellule :

Sub AfficherPhotos(Eqt)
    Dim Cel As Range, Cpt As Integer, TabPhoto()
    Application.ScreenUpdating = False
    TabPhoto = Array("J5:L14", "N5:N14", "J16:L24", "N16:N24")
    ' on efface les photos existantes sur la feuille si elles sont sur les zones Image
    For Each Sh In Sheets("Fiche").Shapes
        If Not Intersect(Sh.TopLeftCell, Range("J5:L14, N5:N14, J16:L24, N16:N24")) Is Nothing Then Sh.Delete
    Next
    ' on recherche l'équipement sélectionné
    Set Cel = Sheets("Données").Range("B:B").Find(Eqt)
    ' si on le trouve
    If Not Cel Is Nothing Then
        ' compteur des images
        Cpt = 0
        ' on boucle sur les shapes de la feuille Données
        For Each Sh In Sheets("Données").Shapes
            ' si le coin supérieur gauche du shape se trouve sur la ligne de l'équipement
            If Sh.TopLeftCell.Row = Cel.Row Then
                ' on le copy
                Sh.Copy
                ' on le colle en le renommant comme l'image d'origine
                ActiveSheet.Pictures.Paste.Name = Sh.Name
                ' sur la feuille Fiche avec le Shape dont le nom est connu
                With ActiveSheet.Shapes(Sh.Name)
                    ' on autorise "sa déformation"
                    .LockAspectRatio = msoFalse
                    ' on le positionne et redimensionne de façon centrée sur la première zone image
                    .Height = Range(TabPhoto(Cpt)).Height - 8
                    .Top = Range(TabPhoto(Cpt)).Top + ((Range(TabPhoto(Cpt)).Height - .Height) / 2)
                    .Width = Range(TabPhoto(Cpt)).Width - 8
                    .Left = Range(TabPhoto(Cpt)).Left + ((Range(TabPhoto(Cpt)).Width - .Width) / 2)
                End With
                ' on incrémente le numéro de la zone image
                Cpt = Cpt + 1
                ' si l'on en a copié 4, alors on sort prématurément de la boucle
                If Cpt >= 4 Then Exit For
            End If
        Next
    End If
End Sub

Après le reste, ce n'est qu'une histoire de boucle, dont celle sur un tableau qui donne les coordonnées de vos zones images de la feuille Fiche.

Le fichier :

8copie-de-catalogue-equipement-lrd.zip (1.13 Mo)

@ bientôt

LouReeD

Le 10/05/2025 à 16:20

Merci à tous d'avoir répondu à ma demande. Vos codes fonctionnent bien.

Je peux maintenant copier des images d'une feuille à une autre, même en l'absence d'images dans la plage source désignée.

Salutations,

Renaud D.

Le 10/05/2025 à 17:02

Bonjour,

merci pour ce retour, et je prend une partie des remerciements collectif à mon compte !

@ bientôt

LouReeD

Rechercher des sujets similaires à "copie photos feuille fonction donnees"