XL 2010 Image en fonction d'une lisdéroulante

[jeromeN95]

Bonsoir à tous,
en colonne A, une liste d'image.

en cellule D2, on choisi dans cette Liste intitulé "Liste Poste", et l'image s'affiche en H2

Voir exemple en PJ.

d'avance merci pour votre aide car cela fait quelques heure que je creuse sur le forum...

 

[BOISGONTIER]

Bonjour,

ComboBox images

Boisgontier

 

[sylvanu]

Bonjour Jérome, Boisgontier,
En PJ un essai qui évite de dupliquer les images.
Une astuce en les rendant toutes invisibles sauf celle désirée.
Code très simple à modifier.

Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Target.Address = "$D$2" Then                     ' Si D2 modifiée
        For Im = 1 To 6                                 ' Masquer toutes les images
            Name = [ListeImages].Cells(Im, 1)           ' Extraire le nom de l'image
            ActiveSheet.Shapes(Name).Visible = False    ' La masquer
        Next Im
        Name = [Poste]                                  ' Récupérer nom photo désirée
        ActiveSheet.Shapes(Name).Visible = True         ' La rendre visible
    End If
End Sub

 

[sylvanu]

Re,
Un autre exemple avec 30 images, juste pour le fun.

 

[jeromeN95]

Bonjour et merci.
C'est vraiment impressionnant, d'ailleurs le deuxième fichier je ne comprend même pas où sont stocker les images ?

Sinon, le premier fichier c'est presque ça,
j'aimerai que les images ne soit pas déplacer.
Simplement que l'image soit "appeler".

Car le fichier va également servir à autre choses et si il y a des lignes supprimer, le poids a vite devenir insupportable.

Est-ce possible ?

 

[sylvanu]

Bonjour,
1- Les images sont stockées ... dans la page. Seulement elles sont invisibles.
2- Une image ne peut pas être appelée au sens où vous l'entendez. Du genre =Image59 comme formule. Cette image sera dupliquée, et la copie placée en H9..
et donc la méthode la moins "lourde" est celle que je vous ai donné.
Les images sont les unes sur les autres mais invisibles et on rend visible que celle qui est demandée.

 

[jeromeN95]

Ah bon, car quand (dans mon fichier exemple ci joint), une cellule contenant une image vide dont le nom fait référence à une cellule ca fonctionne.

Ce que j'aimerai oui vous avez raison c'est appeler une image...
Mon fichier va servir à faire des protocoles.

Il y a au minimum 200 produits.
Je me voit mal mettre 200 images supperposer.

En plus de cela, je doit aussi appeler le nom du produit et son dosage associé (grace à une formul RecherchV).

Et en passant par une combobox ?

 

[sylvanu]

L'image n'est pas copiée dans la cellule H2, elle est copiée dans l'image 8. Donc elle est bien dupliquée.
Je vais regarder comment faire ça au plus simple.

 

[sylvanu]

Bonsoir,
Un essai en PJ qui devrait correspondre à vos besoins.
Ne pas hésiter si problème ou insatisfaction.

 

[jeromeN95]

Bonsoir,
alors bravo, j'adore le principe.
Serait'il possible de modifier une toute petite partie dans le module ?

Dim s As Shape, x As String
' from MTH and JBoisgontier
Sub img()
   For Each s In ActiveSheet.Shapes
    x = s.TopLeftCell.Address
    Range(x).Offset(0, 1) = s.Name
   Next s
End Sub
Sub CollerImage()
Dim F As Worksheet, Nom As String
    SuppressionIm
    NomImage = [ImageName].Value
    Sheets("Liste").Shapes(NomImage).Copy
    Sheets("Header").Select [COLOR=rgb(226, 80, 65)]'Faire également pour les onglets només de 1 à 25 ?[/COLOR]
            [ImageName].Select
            ActiveSheet.Paste
            CentrerImg
    [A1].Select
End Sub
Sub SuppressionIm()
On Error GoTo EndSuppressionIm
For Each sh In Sheets("Header").Shapes   [COLOR=rgb(184, 49, 47)]'Faire également pour les onglets només de 1 à 25 ?[/COLOR]
    If Not Application.Intersect(sh.TopLeftCell, [ImageName]) Is Nothing Then
        sh.Delete
    End If
Next sh
EndSuppressionIm:
End Sub
Sub CentrerImg()
    Dim obj As Shape, c As Range, p As Long
    For Each obj In ActiveSheet.Shapes
        If obj.Type = msoPicture Then
            Set c = obj.TopLeftCell
            ' ajuster hauteur
            obj.Top = c.Top + (c.Top + obj.Top) / 4
            ' centrer
            obj.Left = c.Left + (c.Width - obj.Width) / 2
        End If
    Next obj
End Sub

et également dans la feuille :

Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Target.Address = "$B$6" Then 'Faire pour une plage de cellule ? toujours F5:F23
        CollerImage
    End If
End Sub

 

[sylvanu]

Bonjour Jérome,
C'est le jour des devinettes ?

Serait'il possible de modifier une toute petite partie dans le module ?

Mais encore ?

 

[jeromeN95]

Bon, j'arrive pas bien à adapter.
Ci-joint le fichier d'utilisation.

Send large files free | fast file transfer | secure file upload

TransferXL is the easy, fast, and secure way to transfer large files. No restrictions, and totally free. Send your next transfer with us! | TransferXL

transferxl.com

L'idée est que dans toute les planches (onglet de 1 à 25) , l'utilisateur puisse choisir le produit directement dans une "petite" liste déroulante.
(La liste déroulante sera faite en fonction du type à nettoyer ex. "Sol" sera limiter à la liste nomé "ListePoste".
Ex. : Le type "Poignée de porte" sera limité à la liste nomé "ListeDésinfectantalimentaire")

Pour changer le nom, l'image et la dose du produit. (colonnes E/F/G)

Donc j'ai crée plusieurs liste déroulante dans le dernier onglet "Base produits) qui sert à faire la liste et les régles.

Edit : Le code VBA c'est JEROMENORMANET

 

[sylvanu]

Bonjour Jérome,
C'est le jour des devinettes ?

Ci-joint le fichier d'utilisation.

Mais encore ? C'est ce qu'on appelle de l'humour de répétition.

 

[jeromeN95]

ah bon?
le lien de téléchargement ne fonctionne pas?

 

[sylvanu]

Bonjour Jerome,
Le lien est apparu cette nuit ! Merci.

Je ne sais pas de quel PC et quelle puissance vous disposez, mais sur mon PC ( I5 Win10 Xl2007 8Go RAM ) votre fichier est extrêmement lent, et pourtant ce PC est d'une architecture classique.
Lent au point d'être inexploitable. Si vos client ont le même genre de PC alors ça va poser problème.

J'ai fait un bout de code pour compter les images. J'ai trouvé 1790 images !
C'est beaucoup trop pour XL, il a du mal à suivre.

Malheureusement, je ne pourrais vous aider sur ce coup, outre sa lenteur, XL ne réponds plus au bout de quelques minutes. Il me serait impossible de faire quoi que ce soit.

Sincèrement désolé.

Sub CompterNbImages()
    NbImage = 0
    For Each sht In ThisWorkbook.Worksheets
        NbImage = NbImage + sht.Pictures.Count
    Next sht
    MsgBox ("Nombre images trouvées :  " & NbImage)
End Sub