Microsoft 365 insertion automatique d'images en fonction d'une autre cellule

[Ragnarok001]

bonjour,
je vous joins ce que j'ai commencé grâce à d'autres recherches/fichiers,
je souhaite que le drapeau change dans l'onglet "tableau" à chaque ligne en fonction du pays en colonne A (avec ou sans liste déroulante), or dans le cas présent je n'arrive à le faire mais que sur la première ligne France (onglet "tableau"), pour la seconde ma formule ne fonctionne pas (puisqu'elle est liée à $A$2 et que je ne vois pas comment étendre la sélection..
si vous avez la solution, je suis preneur

en tout cas, merci d'avance..

 

[job75]

Bonsoir,

Voyez le fichier joint et les noms définis Image1 Image2 Image3 Image4.

Les drapeaux s'ajustent aux choix faits en A2 A3 A4 A5.

A+

 

[job75]

Notez que les images de la feuille "tableau" sont obtenues par "Copier comme image" et "Coller" d'une cellule de la feuille "drapeaux" contenant une image.

Une formule comme =Image1 a été insérée dans la barre de formule de chaque image.

 

[Ragnarok001]

Bonjour et merci JOB75 ça fonctionne parfaitement
merci encore !

 

[Ragnarok001]

@job75, juste une question, je viens de regarder la formule if.. dans "Name Manager", dans mon exmple il n'y a que 4 pays mais j'en ai en fait beaucoup plus.. y-a t-il un moyen d'étendre la sélection plutôt que de devoir ajouter à chaque fois un nouveau pays dans la formule ?
merci encore

 

[job75]

Bonjour,

Oui avec du VBA.

A+

 

[Ragnarok001]

ok, merci bp

 

[job75]

Voici la macro, utilisez le fichier joint :

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row = 1 Or Target.Column > 1 Or Target.CountLarge > 1 Or Target(1) = "" Then Exit Sub
Dim p As Object, c As Range
Application.ScreenUpdating = False
'---RAZ---
For Each p In Me.Pictures
    If p.TopLeftCell.Address = Target(1, 2).Address Then p.Delete: Exit For
Next p
'---copier-coller---
With Sheets("drapeaux")
    Set c = .Columns(1).Find(Target, , xlValues, xlWhole)
    If c Is Nothing Then Exit Sub
    For Each p In .Pictures
        If p.TopLeftCell.Address = c(1, 3).Address Then
            ActiveCell.Activate 'sécurité
            p.Copy 'copier
            Do
                Me.Paste 'coller
                DoEvents
            Loop While TypeName(Selection) = "Range" 'attente du collage
            Set Target = Target(1, 2)
            With Selection
                .Left = Target.Left + (Target.Width - .Width) / 2
                .Top = Target.Top + (Target.Height - .Height) / 2
            End With
            ActiveCell.Activate
            Exit For
        End If
    Next p
End With
End Sub

 

[Ragnarok001]

Bonjour job75,
merci bp ça fonctionne très bien, j'ai encore 2 questions si tu me le permets, j'ai essayé de copier coller des noms de pays dans la colonne A onglet "tableau" mais le drapeau ne s'affiche pas automatiquement, je dois soit sélectionner le pays dans la liste déroulante soit l'écrire à la main
Enfin, lorsque je supprime un pays en colonne A, le drapeau reste affiché
merci bp pour toute ton aide !!

 

[job75]

Bonjour Ragnarok001,

La macro précédente fonctionnait pour une entrée unique, celle-ci traite tous les textes en colonne A :

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row = 1 Or Target.Column > 1 Then Exit Sub
Dim c As Range, cc As Range, p As Object
Application.ScreenUpdating = False
'---RAZ---
Me.DrawingObjects.Delete
'---copier-coller des images---
For Each c In Range("A2:A" & Cells.SpecialCells(xlCellTypeLastCell).Row)
    If c <> "" Then
        With Sheets("drapeaux")
            Set cc = .Columns(1).Find(c, , xlValues, xlWhole)
            If Not cc Is Nothing Then
                For Each p In .Pictures
                    If p.TopLeftCell.Address = cc(1, 3).Address Then
                        p.Copy 'copier
                        Me.Paste 'coller
                        With Selection
                            .Left = c(1, 2).Left + (c(1, 2).Width - .Width) / 2
                            .Top = c(1, 2).Top + (c(1, 2).Height - .Height) / 2
                        End With
                        ActiveCell.Activate
                        Exit For
                    End If
                Next p
            End If
        End With
    End If
Next c
End Sub

J'ai supprimé la boucle Do/Loop qui chez moi en tout cas ne servait à rien.

A+

 

[sylvanu]

Bonjour Ragnarok, Job,

juste une question, je viens de regarder la formule if.. dans "Name Manager", dans mon exemple il n'y a que 4 pays mais j'en ai en fait beaucoup plus..

En fait votre approche est une solution sans VBA qui marche, avec :

=INDIRECT(RECHERCHEV(tableau!$A$2;drapeaux!$A$1:$C$20;2;FAUX))

Le seul point qui coinçait est qu'il faut dupliquer la formule pour chaque image de Tableau.
Donc si vous avez beaucoup de drapeaux mais peu de lignes dans Tableau, cette solution reste pertinente.

 

[sylvanu]

Re,
Just for the fun,
Dans ce cas on peut même supprimer la colonne B de Drapeaux, avec comme formule :

=INDIRECT("Drapeaux!$B$"&EQUIV(tableau!$A$2;drapeaux!$A:$A;0))

 

[Ragnarok001]

Bonjour Ragnarok001,

La macro précédente fonctionnait pour une entrée unique, celle-ci traite tous les textes en colonne A :

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row = 1 Or Target.Column > 1 Then Exit Sub
Dim c As Range, cc As Range, p As Object
Application.ScreenUpdating = False
'---RAZ---
Me.DrawingObjects.Delete
'---copier-coller des images---
For Each c In Range("A2:A" & Cells.SpecialCells(xlCellTypeLastCell).Row)
    If c <> "" Then
        With Sheets("drapeaux")
            Set cc = .Columns(1).Find(c, , xlValues, xlWhole)
            If Not cc Is Nothing Then
                For Each p In .Pictures
                    If p.TopLeftCell.Address = cc(1, 3).Address Then
                        p.Copy 'copier
                        Me.Paste 'coller
                        With Selection
                            .Left = c(1, 2).Left + (c(1, 2).Width - .Width) / 2
                            .Top = c(1, 2).Top + (c(1, 2).Height - .Height) / 2
                        End With
                        ActiveCell.Activate
                        Exit For
                    End If
                Next p
            End If
        End With
    End If
Next c
End Sub

J'ai supprimé la boucle Do/Loop qui chez moi en tout cas ne servait à rien.

A+

Bonjour job75, ça marche nickel!! merci encore pour ton aide et ta solution !

 

[Ragnarok001]

Bonjour Ragnarok, Job,

En fait votre approche est une solution sans VBA qui marche, avec :

=INDIRECT(RECHERCHEV(tableau!$A$2;drapeaux!$A$1:$C$20;2;FAUX))

Le seul point qui coinçait est qu'il faut dupliquer la formule pour chaque image de Tableau.
Donc si vous avez beaucoup de drapeaux mais peu de lignes dans Tableau, cette solution reste pertinente.

Bonjour Sylvanu, merci beaucoup pour ta solution qui fonctionne aussi, je garde l'approche VBA car comme tu le dis en fait j'ai beaucoup de lignes
encore merci!!

 

[Ragnarok001]

Bonjour job75, ça marche nickel!! merci encore pour ton aide et ta solution !

Bonjour job75, j'essaie de comprendre le code vba afin de changer la colonne "B" (contenant les drapeaux), je vois bien la colone A2:A mais je ne comprends pas pour la colonne B..
merci d'avance pour tes lumières !