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

UnePassante86

XLDnaute Nouveau
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,
 

Pièces jointes

  • Drapeau.xlsx
    39.5 KB · Affichages: 15

patricktoulon

XLDnaute Barbatruc
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

VB:
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
 

Pièces jointes

  • Drapeau Version Pat.xlsm
    47.8 KB · Affichages: 19

Dranreb

XLDnaute Barbatruc
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) :
Code:
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
 
Dernière édition:

UnePassante86

XLDnaute Nouveau
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

VB:
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

XLDnaute Nouveau
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) :
Code:
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!
 

Discussions similaires

M
Réponses
6
Affichages
403
Réponses
14
Affichages
625

Statistiques des forums

Discussions
311 737
Messages
2 082 036
Membres
101 878
dernier inscrit
1475214