XL 2013 Recherchev image

[WTF]

Bonjour le forum,
JE cherche à faire une recherchev dont le résultat serait une image.
J'ai déjà trouvé pas mal de chose sur le forum et essayé de l'adapter à mon cas.

La solution que j'ai trouvée consiste à inclure dans des champs des formules indirect pour chaque ligne.
Le résultat correspond à ce que je veux, mais n'est pas très souple et ne me semble pas optimal.

Si l'un d'entre vous a une idée.
Je vous mets en PJ le fichier, c'est souvent beaucoup plus clair que des grandes phrases...

Merci à tous

 

[PMO2]

Re : Recherchev image

Bonjour,

Une piste en VBA.
J'ai viré tous les Names de l'espace de noms et réorganisé les images dans une seule feuille (voir la pièce jointe).

1) Copiez le code suivant dans un module Standard

'### Constante à adapter ###
Const FEUILLE_IMAGES As String = "images"
'###########################

Public boolSelectionChange As Boolean

Sub GetImage(Cible As Range, Titre As String)
Dim S As Worksheet
Dim R As Range
Dim C As Range
Dim SH As Shape
Dim PIC As Excel.Picture
Dim nbCol&
Dim j&
Dim var
Dim bool As Boolean
'---
Application.ScreenUpdating = False
'--- Supprime l'image existante ---
On Error Resume Next
ActiveSheet.Shapes(Cible.Address).Delete
Err.Clear
'---
On Error GoTo Erreur
If Cible = "" Then Err.Raise 65000
'--- Recherche la correspondance ---
Set S = Sheets(FEUILLE_IMAGES)
S.Activate
var = S.[a1].CurrentRegion
'--- La bonne colonne ---
nbCol& = UBound(var, 2)
For j& = 1 To nbCol&
  If var(1, j&) = Titre Then
    Set R = S.Range(S.Cells(2, j&), S.Cells(UBound(var, 1), j&))
    Exit For
  End If
Next j&
'--- La bonne cellule ---
For Each C In R
  If C = Cible Then
    bool = True
    Exit For
  End If
Next C
'/////////////////////
'--- Si on a trouvé la bonne cellule ---
If bool Then
  '--- La bonne image ---
  For Each SH In S.Shapes
    If SH.TopLeftCell.Address = C.Address Then
      SH.Copy
      Exit For
    End If
  Next SH
  '--- Colle l'image dans la feuille appelante ---
  Application.EnableEvents = False
  Set S = Cible.Parent
  S.Activate
  Cible.PasteSpecial
  '--- Propriétés de l'image collée ---
  Set PIC = Selection '.OLEFormat.Object
  PIC.Name = Cible.Address
  PIC.Top = Cible.Top + 5
  PIC.Left = Cible.Left + 10
      '°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
      '°°° "BidonClic" est absolument nécessaire °°°
      '°°° pour éviter la sélection des images   °°°
  PIC.OnAction = "BidonClic"
      '°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
  Application.EnableEvents = True
  '---
  boolSelectionChange = True
Else
  Set S = Cible.Parent
  S.Activate
End If
'---
Erreur:
Application.ScreenUpdating = True
End Sub

Sub BidonClic()
'Cette procédure est vide mais est absolument
'nécessaire pour éviter la sélection des images
End Sub

2) Copiez le code suivant dans la fenêtre de code de la feuille concernée (Feuil1 dans cet exemple)

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Application.Intersect(Target, Range("C4:E24,C27:E41")) Is Nothing Then
  Call GetImage(Target, Cells(2, Target.Column))
End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If boolSelectionChange Then
  Target.Select
  boolSelectionChange = False
End If
End Sub

 

[BOISGONTIER]

Re : Recherchev image

Bonsoir,

Exemple

http://boisgontierjacques.free.fr/fichiers/DonneesValidation/DVImagesInternes.xls
http://boisgontierjacques.free.fr/fichiers/Images/Fournitures.xls

JB

 

[WTF]

Re : Recherchev image

Bonjour PMO02

C'est exactement ce que je voulais faire et le résultat est plus fluide que ce qui était avant.

Merci beaucoup.
Je crois qu'il va vraiment falloir que je me mettre au VBA...