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

Dranreb à dit:

Bonsoir
Un essai :

Cliquez pour agrandir...

connaissez vous la méthode Application.CopyObjectsWithCells = True

Cliquez pour agrandir...

patricktoulon à dit:

re
Bonjour @Dudu2 @Dranreb @Jacky67 @UnePassante86

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

Cliquez pour agrandir...

patricktoulon à dit:

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

Cliquez pour agrandir...

Dranreb à dit:

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

Cliquez pour agrandir...