colorer shapes suivant cellules

[gosselien]

Bonjour,

je reviens un peu sur mon PC après quelques semaines d'absence et je suis confronté à un problème de mise en couleur de "shapes";
j'ai une liste de communes avec une couleur de fond sur la ligne qui la contient, j'aimerais remplir la carte à sa gauche suivant la teinte de cette cellule, donc si Charleroi est en bleu dans la liste , la région de charleroi sur la carte sera bleue; ici j'ai un code avec un double clic mais je voudrais une boucle sur l'ensemble des (max 36) communes 🙂

Merci de votre aide

 

[gosselien]

Re : colorer shapes suivant cellules

Merci Pierre pour ta réponse, je la garde sous le coude mais je suis obligé de rester dans ce que je propose dans mon exemple et j'ai , entre autres, besoin que les noms des communes soient affichés.

Patrick

 

[BOISGONTIER]

Re : colorer shapes suivant cellules

Bonjour,

Sub coloriage()
  For Each c In [communesJB]
    If c <> "" Then
      couleur = c.Interior.Color
      ActiveSheet.Shapes(c).Fill.ForeColor.RGB = couleur
    End If
  Next c
End Sub

Les noms des communes pourraient être écrits directement dans les shapes sans shape supplémentaire

http://boisgontierjacques.free.fr/fichiers/Images/CarteFranceDep.xls

Sub EcritNoDepart()
  For Each c In [communesJB]
    If c <> "" Then ecritShape c, c
  Next c
End Sub

Sub ecritShape(nomShape, Libellé, Optional posVert, Optional posHoriz)
    Application.Volatile
    With ActiveSheet.Shapes(nomShape).TextFrame2.TextRange
        .Characters.Text = Libellé
        .Characters.Font.Size = 6
        If IsMissing(posVert) Then
          .Parent.VerticalAnchor = msoAnchorMiddle
        Else
          If posVert = "Bas" Then
           .Parent.VerticalAnchor = msoAnchorBottom
          Else
           .Parent.VerticalAnchor = msoAnchorMiddle
          End If
        End If
        If IsMissing(posHoriz) Then
          .Parent.HorizontalAnchor = msoAnchorCenter
        Else
          If posHoriz = "Gauche" Then
           .Parent.HorizontalAnchor = msoAnchorNone
          Else
           .Parent.HorizontalAnchor = msoAnchorCenter
          End If
        End If
     End With
End Sub

CF Coloriage de Shape

JB

 

[gosselien]

Re : colorer shapes suivant cellules

Super Jacques...

je regarde à ça pour l'adapter mais c'est bien parti comme ça 🙂

Un grand merci

ps: je reviendrai probablement pour d'autres questions

 

[gosselien]

Re : colorer shapes suivant cellules

Voilà...
ça avance doucement 🙂

1 question: est-il possible en survolant la zone que son nom s'affiche ? (un peu à la manière des liens hypertexte)

 

[BOISGONTIER]

Re : colorer shapes suivant cellules

Pour obtenir des bulles

Sub bulles()
  For Each s In ActiveSheet.Shapes
    If s.Type <> 8 Then
      ActiveSheet.Hyperlinks.Add Anchor:=s, Address:="", SubAddress:=""
      tmp = s.Name
      bulle = Application.VLookup(tmp, [communesjb], 1, False)
      If Not IsError(bulle) Then
         libdep = s.Name
         s.Hyperlink.ScreenTip = libdep
      Else
         s.Hyperlink.ScreenTip = "...."
      End If
    End If
  Next s
End Sub

J'ai fait beaucoup de nettoyage!!
Je pense qu'il faudrait partir sur un fichier propre.

http://boisgontierjacques.free.fr/fichiers/Images/CarteBelgique.xls

JB

 

[gosselien]

Re : colorer shapes suivant cellules

Oui , tu as raison....

Je nettoye un peu tout ça , ce fichier (le dessin du Hainaut) vient du net, pas de moi, je l'ai trouvé ici:

Je pense qu'il y a pas mal de choses (tu l'as vu) genre *Free* et autres qui sont inutiles 🙂

Hainaut: Cartes géographiques gratuites, cartes géographiques muettes gratuites, cartes vierges gratuites, fonds de cartes gratuits


Merci encore