Image en fonction de la valeur d'une cellule

Bonjour à tous,

Cela fait bien longtemps que je n'étais pas retourné sur le forum !!

J'ai besoin d'aide mes amis....Je souhaite afficher une image en fonction de al valeur d'une cellule (sélectionné dans une liste déroulante). J'ai déjà tenté de le faire via la fonction "appareil photo" de Excel, cela fonctionnais mais alourdissait considérablement le fichier de travail (plus de 60Mo...inutilisable dans le monde du travail).

Je fais donc appel à vous :

Sur le fichier ci-joint, dans les onglets Collège 1 et Foyer 2 vous trouverez les cellules (en jaune, /!\ se répète sur chaque feuilles de chaque onglet) où les pictogrammes doivent être visible.

J'aimerais,

1. A la demande d'une exécution (bouton à cliquer par l'utilisateur), que la recherche se fasse automatiquement

ou

2. A chaque fois que la valeur de la cellule de référence change (cellule juste en dessous de la case jaune [la liste déroulante]).

J'ai pensé à une solution par VBA, même si je n'ai pas vraiment d'idée sur le développement, ou ne serait-ce que le raisonnement.

Sinon, si la méthode par automatisation est impossible : pouvons-nous ajouter une zone "volante" au dessus des menus qui suivrais l'utilisateur quand il se déplace dans l'onglet (mouvement transversaux et horizontaux) afin qu'il est toujours à disposition la possibilité de lui-même ajouter les pictogrammes en fonction des référence de cellules ? Mais qui ne devrait pas s'imprimer ?

Je précise une nouvelle fois que vous n'avez ici qu'un échantillon du fichier. De plus, il faut que je comprenne et que je puisse facilement expliquer les macros (s'il y en a) à un collègue. Je ne serais pas en charge de la maintenance du fichier dans le futur.

Je vous remercie d'avance pour votre aide, et reste à disposition en cas de question.

ps : je suis sur office 365 (version 2102)

Salut YouniCornnn,

Un plaisir de te revoir !

Voici un sujet similaire si tu parviens à adapter le code : https://forum.excel-pratique.com/excel/afficher-image-selon-valeur-162365#p1005108

A chaque changement dans la cellule, la photo est modifiée, sans bouton (toutes les images se trouvant dans le même dossier).

Cdlt,

Bonsoir,

Voir pj fait uniquement sur onglet collège 1...... semaine du 3 au 7

Slts

On se retrouve une nouvelle fois ! Pour quelque chose de moins audacieux et complexe que la dernière fois j'espère (ça devrait être le cas...)

boss_68, il me semble, et arr^te moi si je me trompe que tu utilise la fonction appareil photo de Excel, en attribuant une adresse à une image et un nom. C'est procédure, je l'ai testé, mais impossible à mettre ne plce dans le rél, le fichier final étant beaucoup trop volumineux comme indiqué dans les explications.

J'ai même compris comment enlever le bord (très moche à moitié gris / transparent). Mais je te remerci pour ton aide !

3gb, je vais me pencher sur ta proposition, je le testerais demain et je te tiendrais au courant dans la foulé.

Bonne soirée à vous deux !

3GB..........

BON, j'ai pas pu m'empecher d'essayer, mais ça ne fonctionne pas. Il ne se passe rien du tout lorsque je change la valeur de la cellule de référence.

J'ai un peu tout essayé je vois pas comment tu arrive à afficher l'image, est-ce que tu as un fichier d'exemple ? Je vais tout de même essayer de demander à la personne que tu as aidé si elle à tjrs son ficher.

Le code en question, il faut le placer dans le module de la feuille contenant la fameuse cellule qui subira les changements (la liste déroulante).

Il faut évidemment adapter les références et le répertoire. Ensuite, il faut que les valeurs de cette cellule correspondent à un nom de fichier dont l'extension est jpg.

Je n'ai pas de fichier exemple, bien qu'il ne serait pas compliqué d'en créer un. Le seul problème, c'est que je ne pourrais pas créer à l'avance la liste déroulante qui contienne les noms de tes fichiers. C'est ce point qu'il faudra éventuellement adapter.

Je recopie le code ici pour que l'on continue sur ce fil plutôt que sur celui clôturé par Theyoshi.

private sub worksheet_change(byval target as range)
dim r as range
set r = intersect(target, range("A1")) 'A1 contient la liste déroulante avec les noms de fichier.
if not r is nothing then
    spath$ = environ("userprofile") & "\Downloads\" 'chemin à adapter (répertoire contenant les images)
    sExt$ = ".jpg" 'extension à adpater éventuellement
    sfilename$ = spath & r.value & sExt
    with me
        if ShapeExists("Photo") then .shapes("Photo").delete
        if dir(sfilename) = "" then exit sub 'le chemin du fichier n'est pas trouvé, sortie de procédure
        set rDest = .range("D1") 'cellule de destination des images à adapter
        with .shapes.addpicture(sfilename, msofalse, msotrue, rDest.left, rDest.top, -1, -1)
            .name = "Photo"
            .lockaspectratio = true
            .width = rDest.width 'la largeur de l'image est définie par rapport à la largeur de la cellule de destination
        end with
    end with
end if
end sub

function ShapeExists(sName$, optional ws as worksheet) as boolean
if ws is nothing then set ws = activesheet
on error resume next
ShapeExists = ws.shapes(sName).id
end function

Bonne soirée,

Bonjour à tous,

Un autre idée, à voir avec le nombre de colonnes et de feuilles, c'est d'utilisée des images liées

Voici le fichier avec la moulinette (certainement pas optimisée)

A+

Salut Bruno,

Je ne connaissais pas les images liées, j'ai donc fait une petite recherche sur mon moteur préféré, merci pour cette découverte !

Pour l'instant, je ne peux pas mais je jetterai probablement un oeil à ton fichier

Bonne soirée,

Bonjour Bruno,

Malheureusement ta solution est possible pour 1 ou deux feuilles. La gestion des images, plus des noms est un enfer pour excel. En optimisant au maximum j'atteignais presque 50Mo sur un version optimisé mais incomplète pour mon fichier de travail. (voir le screen)

J'aurais pu vous le partager, mais il faut tout que j'anonymise, et j'ai autre chose à faire ^^' COMME par exemple tester le code de 3GB

Okay en bidouillant un peu, j'ai réussi à sortir un fichier image sur la feuille à chaque changement.

Mais, je pense que là où j'ai un soucis c'est sur le chemin d'accès de l'image.

En testant de mettre les images dans "Download" ça fonctionne. En testant de mettre cette adresse directement "C:\Users\XX XX\Document local\1. XXXX\XX XXX\XXXXX XXXXX\Forum\Images" [en reprenant le code initialement que tu avais proposé sur le problème de Theyoshi cela ne fonctionne pas. Le code ne trouve pas les images.

Ensuite on parlerais de la taille des images et de leur position.

Bonjour,

Autre solution, les images sont toutes renommées avec le nom qui leur est associé(les espaces sont remplacés par des" _")

les macros se trouvent dans les modules des feuilles

macro dans le module de la feuille "Collège 1"

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    If Not Intersect(Target, Range("A19:DU19")) Is Nothing Then
        Set f1 = Sheets("Paramètres")
        Set f2 = Sheets("Collège 1")
        'suppression des images de la sélection précédente
        For Each Sh In f2.Shapes
            On Error Resume Next
            If Sh.TopLeftCell.Address = f2.Cells(Target.Row - 1, Target.Column).Address Then
                If Err.Number = 0 Then
                    Sh.Delete
                    'Exit For
                End If
            End If
        Next
        Item = Replace(Target, " ", "_")
        Sh = Application.Match(Target, f1.Range("A1:A30"), 0):
        f1.Shapes(Item).Copy
        f2.Paste Cells(Target.Row - 1, Target.Column)
        'positionnement central de l'image
        With ActiveSheet.Shapes(Item)
            .Top = Cells(Target.Row - 1, Target.Column).Top + 10
            .Left = Cells(Target.Row - 1, Target.Column).Left + 120
        End With
    End If
End Sub

macro dans le module de la feuille "Foyer 2"

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    If Not Intersect(Target, Range("A20:DU20,A42:DU42")) Is Nothing Then
        Set f1 = Sheets("Paramètres")
        Set f2 = Sheets("Foyer 2")
        'suppression des images de la sélection précédente
        For Each Sh In f2.Shapes
            On Error Resume Next
            If Sh.TopLeftCell.Address = f2.Cells(Target.Row - 1, Target.Column).Address Then
                If Err.Number = 0 Then
                    Sh.Delete
                End If
            End If
        Next
        Item = Replace(Target, " ", "_")
        Sh = Application.Match(Target, f1.Range("A1:A30"), 0):
        f1.Shapes(Item).Copy
        f2.Paste Cells(Target.Row - 1, Target.Column)
        'positionnement central de l'image
        With ActiveSheet.Shapes(Item)
            .Top = Cells(Target.Row - 1, Target.Column).Top + 10
            .Left = Cells(Target.Row - 1, Target.Column).Left + 120
        End With
    End If
End Sub

Ce sont les mêmes sauf l'emplacement des lignes des listes déroulantes et du nom de la feuille, facile à recopier sur d'autres feuilles et à adapter.

Cdlt

Arturo je pense que tu es sur la bonne piste, ton code fonctionne à quelque détails.

Lors de la saisie de deux lignes portant a même valeur, la 1ère est écrasé (dans l'exemple : " Label Bio Europe").

De plus sur certaine images, il arrive que 2 images se collent dans la cellule.

Sinon c'est assez bleffant et plus proche de ce que je souhaite : comme ça pas besoin d'avoir les images dans un répertoire (le fichier est autonome) !

Ok, je regarde ça dans un moment

Bonjour YouniCornn

YouniCornnn a écrit :

Bonjour Bruno,

Malheureusement ta solution est possible pour 1 ou deux feuilles. La gestion des images, plus des noms est un enfer pour excel. En optimisant au maximum j'atteignais presque 50Mo sur un version optimisé mais incomplète pour mon fichier de travail. (voir le screen)

J'aurais pu vous le partager, mais il faut tout que j'anonymise, et j'ai autre chose à faire ^^' COMME par exemple tester le code de 3GB

Attention je parle d'images liées avec celles qui se trouve dans le classeur, rien d'autre

Copier Cellule B1 de "Paramètres", collage spéciale Image avec liaison dans la feuille "Collège 1" par exemple

Ceci dit, avec la seule feuille "Collège 1" et toutes les colonnes remplies, le fichier passe à 5Mo

A+

Alors soit je confond image lié et fonction appareil photo, mais dans les deux cas l'images "contient une formule". Lorsque je procède à ce copier/coller en image lié rien de se passe.

J'imagine qu'il y a autre chose à faire derrière ?

Re,

Avez-vous au moins essayé mon fichier ici

https://forum.excel-pratique.com/s/goto/1023372

Petite correction apportée ce matin, et ne fonctionne que pour la feuille Collège pour l'instant

Il faut lancer le code par le menu développeur

A+

Ahhhhh, c'est pour ça que je ne voyais rien. J'avais pas saisi qu'il y avait du code derrière ^^'

Alors du coup un truc qui me fait peur c'est ça :

Pour 1 feuille dans ton fichier. Moi au total, j'ai 12 onglets dont 4 ou 5 avec des menus midi et soir, donc pour un total (si mes calculs sont corrects) de 720 images liés.

Pour continuer dans ce sens, je pense que tu a réussi à automatiser quelque chose que j'avais parametré à la main (image du gestionnaire des noms de ta version)

Ma version (sur le fichier de 54Mo) pour un seul onglet comportant menu du midi, plus menu du soir :

Ensuite dans le code, il se met en erreur ici (même si à la fin j'ai bien les images au bon endroit)

Set Pic = ActiveSheet.Pictures.Paste(Link:=True)

Donc je pense qu'au final nous parlons de là même chose =)

Sinon, voici la modification apportée à ma proposition, de plus un double-clic sur la cellule jaune efface toutes les images sélectionnées de la cellule.

Cdlt

Arturo je te remercie pour ton aide !

Sans vouloir être trop demandeur, est-ce qu'il est possible que tu intègre des commentaire dans le code ('exemple commentaire), afin de m'aider à comprendre ce que fais chaque ligne ?

comme tu as déjà fais pour cette ligne :

f2.Paste Cells(Target.Row - 1, Target.Column)
        'positionnement de l'image

Je comprends globalement le code, mais le détails reste flou, et je n'en serais pas l'utilisateur final, donc je voudrais permettre à ce dernier de pouvoir comprendre le processus qui à été mis en place afin de l'aider si des modifications viennent à venir.

Et enfin pour terminer, quel argument dois-je modifier pour que le pictogramme se positionne tout seul au milieu de la cellule de destination ?

Petit édit pour une question supplémentaire :

Le code n'est pas exactement le même (en dehors des changement de cellule et autre argument inhérent à la feuille de travail), est ce qu'il y a une raison ?

Si je venais à en copier un pour desservir tous mes autres onglets, lequel devrais-je prendre ?

Edit 2 :

La fonction permettant la suppression par double-clic dans la cellule ne fonctionne pas pour le 1ere cellule de chaque ligne à gauche (midi et soir).

Au lieu d'un double clic est-il possible de simplement créer une macro que je viendrais ajouté à une autre (dans mon classeur d'origine), et qui me sert à effacer toute les rentrées présente sur le classeur ?

J'ai pas le temps pour le moment de tout traiter, je dois m'absenter, alors je n'ai fait que la première question.

La macro avec les commentaires est déplacée dans le module "ThisWorkBook" pour qu'elle puisse marcher sur toutes les feuilles.

Juste un petit problème à faire de votre côté, dans la feuille "Collège 1" la ligne des listes déroulantes est la 19 alors que dans "Foyer 2" elle est en 20 et 42. pour que cela marche insérez une ligne au-dessus du tableau de la feuille "Collège 1" afin que la ligne des listes déroulantes soit aussi sur la 20.

Pour le reste, je regarderai à mon retour.

Cdlt