XL 2016 VBA - ajouter un drapeau dans une cellule suivant le pays choisi

[UnePassante86]

Bonjour à tous,

J'aurai besoin d'ajouter un drapeau dans une cellule suivant le pays choisi!

J'ai joint le fichier en question, avec les explications complémentaires

merci pour votre aide,

juste de passage,

 

[Dranreb]

Bonsoir
Un essai :

 

[UnePassante86]

Bonsoir
Un essai :

Tu as bien cerné ma demande, il y a juste deux problèmes: le fichier bug (il se ferme tout seul) et parfois les drapeaux disparaissent lorsque l'on change de sélection :/

 

[patricktoulon]

bonjour
une autre proposition
sans avoir a préciser le nom de l'image puisqu'il est senser avoir la liste dans la feuil2
connaissez vous la méthode Application.CopyObjectsWithCells = True
avec cette méthode activée tu copy une cell avec toutes shapes ou picture qui s'y trouverait (peu importe son nom)
partie de la il te suffit de trouver la valeur de target dans ton tableau en feuille 2 colonne"B"
ensuite tu copie l'offset (,1)
et tes shapes n'ont pas besoins d'avoir le nom du pays qu'elle représentent

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim plagerecherche As Range, cel As Range, c&
    If Target.Column <> 3 Or Target.Count > 1 Then Exit Sub
    c = Target.Offset(, -1).Interior.Color ' au cas ou la couleur ne serait pas la meme on la memoreise
    Application.CopyObjectsWithCells = True
    For Each shap In Feuil1.Shapes
        x = shap.TopLeftCell.Address(0, 0): y = Target.Offset(, -1).Address(0, 0)
         If x = y Then shap.Delete: Exit For
        DoEvents
    Next

    tablo = Feuil2.Range("Tableau1").Columns(1)
    For i = 1 To UBound(tablo)
        If tablo(i, 1) = Target Then Set cel = Feuil2.Range("Tableau1").Cells(i, 2): Exit For
    Next
    If Not cel Is Nothing Then cel.Copy Target.Offset(, -1)
    Application.CopyObjectsWithCells = False
    Target.Offset(, -1).Interior.Color = c ' au cas ou la couleur ne serait pas la meme on la remet
End Sub

 

[Dranreb]

Bonjour.
Je n'ai pas le phénomène que vous décrivez dans le Temp.xlsm que j'ai joint.

 

[Dranreb]

Au cas ou vous auriez simplement copié le code dans le projet d'un autre classeur sans avoir vu que les images modèles doivent avoir pour noms ceux de leurs pays, ajoutez ça dans le module Feuil2 (Données pays) :

Option Explicit
Private Sub Worksheet_Activate()
   NommerShapes
   End Sub
Private Sub Worksheet_Deactivate()
   NommerShapes
   End Sub
Private Sub NommerShapes()
   Dim Rng As Range, Shp As Shape, Cel As Range, DifCol As Integer
   With Me.ListObjects(1)
      Set Rng = .ListColumns("Flag").DataBodyRange
      DifCol = .ListColumns("Country").Index - .ListColumns("Flag").Index
      End With
   For Each Shp In Me.Shapes
      Set Cel = Intersect(Rng, Shp.TopLeftCell)
      If Not Cel Is Nothing Then
         Shp.Name = Cel.Offset(0, DifCol).Value
         Shp.Left = Cel.Left + (Cel.Width - Shp.Width) / 2
         Shp.Top = Cel.Top + (Cel.Height - Shp.Height) / 2
         End If
      Next Shp
   End Sub

 

[Dudu2]

Bonjour @UnePassante86, @Dranreb, @patricktoulon,

connaissez vous la méthode Application.CopyObjectsWithCells = True

Non, je connaissais pas. J'en apprends tous les jours 😉

 

[patricktoulon]

re
Bonjour @Dudu2 @Dranreb @Jacky67 @UnePassante86

vous remercierez @job75 qui me l'a fait découvrir l'année dernière

 

[Jacky67]

re
Bonjour @Dudu2 @Dranreb @Jacky67 @UnePassante86

vous remercierez @job75 qui me l'a fait découvrir l'année dernière

Bonjour à tous
Dans la boite à outils
Même que cela fonctionne sur xl2007
Merci à job75 😇🙂😉

 

[UnePassante86]

bonjour
une autre proposition
sans avoir a préciser le nom de l'image puisqu'il est senser avoir la liste dans la feuil2
connaissez vous la méthode Application.CopyObjectsWithCells = True
avec cette méthode activée tu copy une cell avec toutes shapes ou picture qui s'y trouverait (peu importe son nom)
partie de la il te suffit de trouver la valeur de target dans ton tableau en feuille 2 colonne"B"
ensuite tu copie l'offset (,1)
et tes shapes n'ont pas besoins d'avoir le nom du pays qu'elle représentent

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim plagerecherche As Range, cel As Range, c&
    If Target.Column <> 3 Or Target.Count > 1 Then Exit Sub
    c = Target.Offset(, -1).Interior.Color ' au cas ou la couleur ne serait pas la meme on la memoreise
    Application.CopyObjectsWithCells = True
    For Each shap In Feuil1.Shapes
        x = shap.TopLeftCell.Address(0, 0): y = Target.Offset(, -1).Address(0, 0)
         If x = y Then shap.Delete: Exit For
        DoEvents
    Next

    tablo = Feuil2.Range("Tableau1").Columns(1)
    For i = 1 To UBound(tablo)
        If tablo(i, 1) = Target Then Set cel = Feuil2.Range("Tableau1").Cells(i, 2): Exit For
    Next
    If Not cel Is Nothing Then cel.Copy Target.Offset(, -1)
    Application.CopyObjectsWithCells = False
    Target.Offset(, -1).Interior.Color = c ' au cas ou la couleur ne serait pas la meme on la remet
End Sub

c'est parfait! Merci beaucoup!! 🙂

 

[UnePassante86]

Au cas ou vous auriez simplement copié le code dans le projet d'un autre classeur sans avoir vu que les images modèles doivent avoir pour noms ceux de leurs pays, ajoutez ça dans le module Feuil2 (Données pays) :

Option Explicit
Private Sub Worksheet_Activate()
   NommerShapes
   End Sub
Private Sub Worksheet_Deactivate()
   NommerShapes
   End Sub
Private Sub NommerShapes()
   Dim Rng As Range, Shp As Shape, Cel As Range, DifCol As Integer
   With Me.ListObjects(1)
      Set Rng = .ListColumns("Flag").DataBodyRange
      DifCol = .ListColumns("Country").Index - .ListColumns("Flag").Index
      End With
   For Each Shp In Me.Shapes
      Set Cel = Intersect(Rng, Shp.TopLeftCell)
      If Not Cel Is Nothing Then
         Shp.Name = Cel.Offset(0, DifCol).Value
         Shp.Left = Cel.Left + (Cel.Width - Shp.Width) / 2
         Shp.Top = Cel.Top + (Cel.Height - Shp.Height) / 2
         End If
      Next Shp
   End Sub

Je n'avais pas copie-coller le code, bisare ce bug! mais vraiment merci d'avoir apporté ton aide!