Logo en menu liste déroulante

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion anthoYS
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
anthoYS

anthoYS

XLDnaute Barbatruc
Bonsoir,

Comment faire pour que quand je selectionne le menu liste déroulante apparaisse, une image logo dans la cellule...

Par exemple je choisi mon magazin dans une cellule par menu liste déroulante, je souhaite que le vrai logo apparaisse plutôt que de lire "Carrefour" ou "Leclerc"...
Logo collé par image...

Merci d'avance aux "excel-downloads forumeurs"
 
Trier par date Trier par votes
Re : Logo en menu liste déroulante

Merci BOISGONTIER pour ton dernier fichier "DVImage3.zip".
Vraiment bien l'exemple.

Code de la feuille :

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Column = [COLOR="Yellow"]1 [/COLOR]Then
    '-- suppression
    For Each s In ActiveSheet.Shapes
      If s.Type = [COLOR="#ffff00"]13 [/COLOR]Then
        If s.TopLeftCell.Address = Target.Address Then
          s.Delete
        End If
      End If
    Next s
    '--
    If Target <> "" Then
      On Error Resume Next
      Sheets("images").Shapes(Target).Copy
      If Err = 0 Then
        'Target.Offset([COLOR="#ffff00"]0, 1[/COLOR]).Select
        ActiveSheet.Paste
        Selection.ShapeRange.Left = ActiveCell.Left [COLOR="#ffff00"]+ 9[/COLOR]
        Selection.ShapeRange.Top = ActiveCell.Top [COLOR="#ffff00"]+ 5[/COLOR]
        Target.Select
      End If
    End If
   End If
End Sub

(référence à ton fichier)

Comment l'adapter à une feuille 'Rcp' ou les logos sont en AK2:AK9 (B2:B4, 'Images') et les noms associés en liste déroulante en AJ2:AJ9 (A2:A4, 'Images') ?

Le choix de ces logos d'abord par menu liste déroulante des noms doit s'effectuer en N (A) d'un autre onglet 'Cpa', à partir de N2 (A2, 'ChoixV2') plus exactement, jusqu'à plus bas par incrémentation...
Que faut-il remplacer dans le code et par quoi?

J'ai une idée...

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Column = [COLOR="#ffff00"]14 [/COLOR]Then
    '-- suppression
    For Each s In ActiveSheet.Shapes
      If s.Type = [COLOR="#ffff00"]13[/COLOR] Then
        If s.TopLeftCell.Address = Target.Address Then
          s.Delete
        End If
      End If
    Next s
    '--
    If Target <> "" Then
      On Error Resume Next
      Sheets("Rcp").Shapes(Target).Copy
      If Err = 0 Then
        'Target.Offset([COLOR="#ffff00"]19, 20[/COLOR]).Select
        ActiveSheet.Paste
        Selection.ShapeRange.Left = ActiveCell.Left [COLOR="#ffff00"]+ 9[/COLOR]
        Selection.ShapeRange.Top = ActiveCell.Top [COLOR="#ffff00"]+ 5[/COLOR]
        Target.Select
      End If
    End If
   End If
End Sub

Mais est-ce la bonne?

Les images doivent-elles êtres nommées comme le choix menu liste déroulante -mais sans la majuscule-?

@+
 
Dernière édition:
Vote positif 0 Vote négatif
Re : Logo en menu liste déroulante

Bonjour,

Merci pour tout, un autre problème qui vient s'ajouter, oK, pour le code, parfait. Sauf que dans mon exemple les logos sont petits, comment les recentrer dans le cadre car hauteur de ligne 15.

Merci par avance.

Voir PJ téléchargeable >>>>>ici<<<<<<.

Bonne soirée!
 
Vote positif 0 Vote négatif
Re : Logo en menu liste déroulante

Bonsoir,

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Column = 14 And Target.Count = 1 Then
    '-- suppression
    For Each s In ActiveSheet.Shapes
      If s.Type = 13 Then
        If s.TopLeftCell.Address = Target.Address Then
          s.Delete
        End If
      End If
    Next s
    '--
    If Target <> "" Then
      On Error Resume Next
      Sheets("Rcp").Shapes(Target).Copy
      If Err = 0 Then
        ActiveSheet.Paste
        Selection.ShapeRange.Left = ActiveCell.Left + 9
        Selection.ShapeRange.Top = ActiveCell.Top + 5
        
        largeurImage = Sheets("Rcp").Shapes(Target).Width
        HauteurImage = Sheets("Rcp").Shapes(Target).Height
        Selection.ShapeRange.Left = ActiveCell.Left + ActiveCell.Width / 2 - largeurImage / 2
        Selection.ShapeRange.Top = ActiveCell.Top + 5
        Rows(Target.Row).RowHeight = HauteurImage + 10
        
        Target.Select
      End If
    End If
   End If
End Sub

http://boisgontierjacques.free.fr/fichiers/DonneesValidation/DVImage3.xls

JB
 
Dernière édition:
Vote positif 0 Vote négatif
Re : Logo en menu liste déroulante

Merci, mais quand on choisi, ok ça centre, mais la hauteur passe de 15 à presque 24.
N'est-il pas possible de conserver la hauteur de 15 -tout en centrant-?

Merci encore.
 
Dernière édition:
Vote positif 0 Vote négatif
Re : Logo en menu liste déroulante

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Column = 14 And Target.Count = 1 Then
    '-- suppression
    For Each s In ActiveSheet.Shapes
      If s.Type = 13 Then
        If s.TopLeftCell.Address = Target.Address Then s.Delete
      End If
    Next s
    '--
    If Target <> "" Then
      On Error Resume Next
      Sheets("Rcp").Shapes(Target).Copy
      If Err = 0 Then
        ActiveSheet.Paste
        largeurImage = Sheets("Rcp").Shapes(Target).Width
        HauteurImage = Sheets("Rcp").Shapes(Target).Height
        Selection.ShapeRange.Left = ActiveCell.Left + ActiveCell.Width / 2 - largeurImage / 2
        Selection.ShapeRange.Top = ActiveCell.Top + 0
        Rows(Target.Row).RowHeight = HauteurImage
        Target.Select
      End If
    End If
   End If
End Sub

JB
 
Vote positif 0 Vote négatif
Re : Logo en menu liste déroulante

Bonjour à tous ;

Qu'est-ce qui cloche ici dans ce code?

Je souhaite afficher le logo après la selection.

Mais rien n'y fait...

Code: 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Application.Intersect(Target, Range("K:K")) Is Nothing And IsEmpty(Target) Then
Cells(Target.Row, 11) = Date
End If
If Not Application.Intersect(Target, Range("J:J")) Is Nothing And IsEmpty(Target) Then
Calendrier.Show
End If
Cancel = True
If Target.Column = 7 Then
Cells(Target.Row, 1).Interior.ColorIndex = 4
Cells(Target.Row, 2).Interior.ColorIndex = 4
Cells(Target.Row, 3).Interior.ColorIndex = 4
Cells(Target.Row, 4).Interior.ColorIndex = 4
Cells(Target.Row, 5).Interior.ColorIndex = 4
End If
If Target.Column = 8 Then
Cells(Target.Row, 1).Interior.ColorIndex = 15
Cells(Target.Row, 2).Interior.ColorIndex = 15
Cells(Target.Row, 3).Interior.ColorIndex = 15
Cells(Target.Row, 4).Interior.ColorIndex = 15
Cells(Target.Row, 5).Interior.ColorIndex = 15
End If
If Target.Column = 12 Then
Cells(Target.Row, 12).Interior.ColorIndex = 4
Cells(Target.Row, 12) = Date
End If
  If Target.Column = 9 And Target.Count = 1 Then
    '-- suppression
    For Each S In ActiveSheet.Shapes
      If S.Type = 8 Then
        If S.TopLeftCell.Address = Target.Address Then S.Delete
      End If
    Next S
    '--
    If Target <> "" Then
      On Error Resume Next
      Sheets("mdP").Shapes(Target).Copy
      If Err = 0 Then
        ActiveSheet.Paste
        largeurImage = Sheets("mdP").Shapes(Target).Width
        HauteurImage = Sheets("mdP").Shapes(Target).Height
        Selection.ShapeRange.Left = ActiveCell.Left + ActiveCell.Width / 2 - largeurImage / 2
        Selection.ShapeRange.Top = ActiveCell.Top + 0
        Rows(Target.Row).RowHeight = 39
        Target.Select
      End If
    End If
   End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect([I2:I10000], Target) Is Nothing Then
    On Error Resume Next
    Target.Interior.ColorIndex = [Navig].Find(Target, LookAt:=xlWhole).Interior.ColorIndex
  Target.Font.ColorIndex = [Navig].Find(Target, LookAt:=xlWhole).Font.ColorIndex
  End If
End Sub

Merci d'avance

fichier
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

N
  • Question Question
Microsoft 365 Sélectionner cellule en fonction d'une liste déroulante
Réponses
9
Affichages
224
Dranreb
Dranreb
E
  • Question Question
XL 2016 Liste déroulante "pré-chargée"
Réponses
10
Affichages
245
sylvanu
sylvanu
S
  • Question Question
XL 2016 formule de calcul en fonction du choix de la liste déroulante
2
Réponses
18
Affichages
1 K
Silent
S
J
  • Résolu(e)
Microsoft 365 afficher image selon valeur cellule
Réponses
2
Affichages
190
juju91
J
T
  • Résolu(e)
XL 2019 Afficher un mot dans une colonne paramétrée en liste déroulante
Réponses
4
Affichages
175
telemarrk
T
M
  • Résolu(e)
XL pour MAC Création d'une liste (non déroulante)
Réponses
3
Affichages
162
Blackfwolf
B
T
  • Résolu(e)
XL 2021 Liste déroulante conditionnée
Réponses
6
Affichages
392
Gégé-45550
Gégé-45550
raelle76
  • Résolu(e)
Microsoft 365 Formule entre 2 feuilles
Réponses
7
Affichages
140
TooFatBoy
TooFatBoy
D
  • Question Question
XL 2021 VBA - Erreur 1004 aléatoire - Image/Logo
Réponses
10
Affichages
810
crocrocro
C
M
  • Résolu(e)
Autres Liste déroulante et cellule vide
Réponses
13
Affichages
351
Marjo2809
M
R
  • Question Question
XL 2010 Problème avec liste déroulante sur des cellule déjà rempli
Réponses
6
Affichages
697
rider
R
R
  • Résolu(e)
Microsoft 365 Champ recherche ou liste déroulante...
Réponses
3
Affichages
200
vgendron
vgendron
S
  • Question Question
Autres liste déroulante dynamique à 2 niveaux
Réponses
2
Affichages
244
saralht
S
J
  • Question Question
Microsoft 365 Images liste déroulante en VBA
2
Réponses
15
Affichages
421
juju91
J
C
  • Question Question
XL 2021 afficher une liste déroulante
Réponses
3
Affichages
374
chrislecycliste
C
M
  • Question Question
XL 2016 liste déroulante formulaire vba excel
2
Réponses
20
Affichages
514
fanch55
fanch55
M
  • Question Question
XL pour MAC Créer une liste dans un menu déroulant
Réponses
3
Affichages
473
Mamounax2000
M
P
  • Question Question
XL 2021 Formules imbriquées
Réponses
13
Affichages
214
papychr
P
eastwick
  • Question Question
XL 2016 cellule en format liste
Réponses
2
Affichages
149
eastwick
eastwick
E
  • Question Question
Microsoft 365 Création d'un filtre sur une cellule avec recherche de mot indexé
Réponses
3
Affichages
162
elgringo123456
E
Retour