Microsoft 365 Carte de france Dynamique

pascaleg80 · 27 Juillet 2020

Bonjour, je souhaite créer une carte de France avec des codes couleurs par département en fonction d'un pourcentage d'atteinte. Quelqu'un peut il m'aider s'il vous plait?
Si je dois résumer, si un département à un %tage d'atteinte d'objectif inf à 80% = Rouge/ entre 80 et 90% (non inclus) = orange et au dela vert/ Si pas de %tage de renseigné, laisser le dép sans couleur.
Ci-joint un fichier pour comprendre ma demande.

Merci par avance et bonne semaine à toutes et tous

Dudu2 · 27 Juillet 2020

L'Équipe,
Grâce à vos cartes et détail Paris, j'ai pu améliorer la chose et propose cette version à Pascale.
Si y a des points à corriger, n'hésite(z) pas à le faire savoir.

Le tableau des gradations de couleurs en fonction des % est évidemment adaptable et extensible à souhait.

Edit: 21h07 modification du code pour ne pas afficher les codes départements dans des Shapes qui ont un équivalent Zoom
Edit: 21h21 modification du code pour l'affectation directe de la couleur au lieu de passer par une décomposition RGB.
Edit: 06h15 modification du centrage de l'affichage des codes départements 54 et 92 pour mieux faire apparaitre le texte.

patricktoulon · 27 Juillet 2020

re
dudu2 tu peux économiser un peu de l'uc
par exemple tu peux faire sauter le calcul RGB et donc faire sauter la fonction (GetRGBFromLong)qui va avec

VB:

'ActiveSheet.Shapes(ShapeName).Fill.ForeColor.RGB = RGB(0, 176, 240)
        Color = Tbl.DataBodyRange.Cells(j, 2).Interior.Color
        On Error Resume Next
        ActiveSheet.Shapes(ShapeName).Fill.ForeColor.RGB = Color 'RGB(GetRGBFromLong(Color, "R"), _
                                                               'GetRGBFromLong(Color, "G"), _
                                                               'GetRGBFromLong(Color, "B"))

Dudu2 · 27 Juillet 2020

@Patrick, tu as raison, j'ai fait la modif.
J'avais fait des essais en affectation directe de la couleur qui n'ont pas abouti, mais j'ai dû me planter dans les tests !

patricktoulon · 27 Juillet 2020

re
un autre exemple
Set Tbl = Range("tableau1").Parent.ListObjects("tableau1")
kézako???????????????

que la feuille concernée soit active ou pas le range(nom du tableau) donne la même chose

msgbox Range("tableau1").Parent.ListObjects("tableau1").address
msgbox Range("tableau1").address

si tu fait set Tbl=Range("tableau1") tout simplement
c'est bien le tableau de la feuill1 qui sera Tbl a l'inverse de la collection listobjects qui a besoins d'etre sur la feuille concernée active

Dudu2 · 27 Juillet 2020

Set Tbl = Range("tableau1").Parent.ListObjects("tableau1")

C'est la méthode que j'utilise pour éviter d'avoir à désigner la feuille sur laquelle on trouve le tableau.

Je pourrais faire:
Set Tbl = ActiveSheet.ListObjects("tableau1")
mais cela impose que la feuille active soit la bonne.

Je pourrais faire:
Set Tbl = ThisWorkbook.Worksheets("Feuil1").ListObjects("tableau1")
mais cela impose de connaître le nom (ou le n°) de la feuille.

Si je fais:
Set Tbl=Range("tableau1") ou Tbl=Range("tableau1")
c'est incompatible car Tbl est ListObject et Range("Tableau1") est un Range.
Et si je dis que Tbl est un Range pour la compatibilité, adieu les DataBodyRange et autres sous-objets des Tableaux Structurés.

patricktoulon · 27 Juillet 2020

re
ca donne çà

VB:

'-------------------------------------------------
'Colorise les Shapes de la carte selon les données
'de "tableau1" et les couleurs de "tableau2"
'-------------------------------------------------
Sub ColoriseShapesSurDonnées()
    Dim Sh As Shape
    Dim ShapeName As String
    Dim Pourcentage As Single
    Dim Color As Long
    Dim Tbl As Range 'ListObject'!!!!!!!!!!!!!!!!!!!!!!!!
    Dim TabDept() As Variant
    Dim TabColor() As Variant
    Dim i As Integer
    Dim j As Integer
    Dim ErrNumber As Variant
    'Chargement des tableaux en mémoire
    'Set Tbl = Range("tableau1").Parent.ListObjects("tableau1")'!!!!!!!!!!!!!!!!!!!!!!!!
    'TabDept = Tbl.DataBodyRange.Value'!!!!!!!!!!!!!!!!!!!!!!!!
    'Set Tbl = Range("tableau2").Parent.ListObjects("tableau2")'!!!!!!!!!!!!!!!!!!!!!!!!
    'TabColor = Tbl.DataBodyRange.Value'!!!!!!!!!!!!!!!!!!!!!!!!
   
    Set Tbl = Range("tableau1")
    TabDept = Tbl.Value
    Set Tbl = Range("tableau2")
    TabColor = Tbl.Value

   
    Call DécoloriseShapes

    'Parcours du tableau des Départements
    For i = 1 To UBound(TabDept)
        'Nom de la Shape correspondante au département
        ShapeName = ShapeNamePrefix & TabDept(i, 1)
        'Pourcentage du département
        Pourcentage = 0
        If IsNumeric(TabDept(i, 3)) Then Pourcentage = TabDept(i, 3)

        'Parcours du tableau des pourcentages
        For j = 1 To UBound(TabColor)
            If TabColor(j, 1) > Pourcentage Then Exit For
        Next j
        If j > 1 Then j = j - 1


        'ActiveSheet.Shapes(ShapeName).Fill.ForeColor.RGB = RGB(0, 176, 240)
        'Color = Tbl.DataBodyRange.Cells(j, 2).Interior.Color'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        Color = Tbl.Cells(j, 2).Interior.Color
       On Error Resume Next
        ActiveSheet.Shapes(ShapeName).Fill.ForeColor.RGB = Color    'RGB(GetRGBFromLong(Color, "R"), _
                                                                    'GetRGBFromLong(Color, "G"), _
                                                                    'GetRGBFromLong(Color, "B"))
        ErrNumber = Err.Number
        On Error GoTo 0

        If ErrNumber Then MsgBox "Shape <" & ShapeName & "> inexistante."
    Next i
End Sub

'---------------------------------------------------------
'Retourne les composantes R, G, B à partir d'un Color Long
'---------------------------------------------------------
'Function GetRGBFromLong(longColor As Long, RGB As String) As Integer
    'Select Case RGB
    'Case "R"
       ' GetRGBFromLong = (longColor Mod 256)
    'Case "G"
        'GetRGBFromLong = (longColor \ 256) Mod 256
    'Case "B"
        'GetRGBFromLong = (longColor \ 65536) Mod 256
    'End Select
'End Function

en suite pourquoi avoir mis les num de départements en "A" et utiliser un concat avec la constante préfixe
alors que si tu met les vrai noms complet en "A" tu fait sauter aussi le concat
et hop!! encore des économies de procc et mémoire
c'est presque rien mais tout ces petits truc mis bout a bout ça fait la diff'

patricktoulon · 27 Juillet 2020

re

C'est la méthode que j'utilise pour éviter d'avoir à désigner la feuille sur laquelle on trouve le tableau.

c'est justement ce que je te dis
Set Tbl = Range("tableau1") désigne bien la Feuil1.Range("tableau1") et pas autre chose

et de la même manière que le databodyrange elle demarre a la ligne 2(sans l’entête )

Dudu2 · 27 Juillet 2020

Oui je sais, mais personnellement je préfère utiliser le ListObjet au Range pour maniper sur les données des tableaux structurés.

De toute façons, la différence en terme de traitement est nulle. Cependant, si ici on n'a besoin que des lignes du DataBodyRange qui correspond à ton Range, si il avait fallu exploiter les noms des colonnes pour déterminer l'indice de colonne le Tbl ListObject aurait été nécessaire.

pascaleg80 · 27 Juillet 2020

Dudu2 à dit:
L'Équipe,
Grâce à vos cartes et détail Paris, j'ai pu améliorer la chose et propose cette version à Pascale.
Si y a des points à corriger, n'hésite(z) pas à le faire savoir.

Le tableau des gradations de couleurs en fonction des % est évidemment adaptable et extensible à souhait.

Edit: 21h07 modification du code pour ne pas afficher les codes départements dans des Shapes qui ont un équivalent Zoom
Edit: 21h21 modification du code pour l'affectation directe de la couleur au lieu de passer par une décomposition RGB.

C'est parfait, vous m'avez parfaitement réglé mon problème et je vous en remercie Mille fois....Vous pouvez être certain que cet outil ma m'être grandement utile .

patricktoulon · 27 Juillet 2020

re
oui pour manipuler les données (lecture/écriture) c'est plus facile avec listobject car tout est chargé en memoire
mais pour une simple lecture unique afin de créer une variable tableau c'est absolument inutile

Dudu2 · 27 Juillet 2020

en suite pourquoi avoir mis les num de départements en "A" et utiliser un concat avec la constante préfixe

Je pourrais te répondre que c'est mon bon plaisir, mais je vais quand même aller plus loin .

En colonne A, je trouve que c'est mieux qu'il y ait les codes des départements "naturels" (83 ,06, etc...) plutôt que des noms de Shapes (FR-83, FR-06, etc...)
Les Shapes auraient aussi pu s'appeler simplement du codes des départements "naturels" et il n'y aurait pas eu besoin de faire de concaténation avec un préfixe.

L'avantage du préfixe devant le code du département c'est qu'il permet d'identifier précisément les Shapes de la carte en excluant toutes autres Shapes qui pourraient venir agrémenter le feuille, sans compter les boutons qui ne sont pas Active X. Même si on ne s'en sert pas dans ce code.

Et puis, j'ai récupéré la carte comme ça donc je ne me suis pas posé de questions.

patricktoulon · 27 Juillet 2020

re

Les Shapes auraient donc pu s'appeler simplement du codes des départements et il n'y aurait pas eu besoin de faire de concaténation avec un préfixe.

et ben non
en cells(1,1) tu a par exemple 35

si je fait set mashape = activesheet.shape(cells(1,1).value)

selon toi je vais chopper la la shapes("35") ou le 35 eme shape

je te le dis parce cet aprem je me suis couillonné tout seul avec ca

Dudu2 · 27 Juillet 2020

@pascaleg80,
Content que nous ayons pu régler ton problème.
Bonne soirée.

Dudu2 · 27 Juillet 2020

selon toi je vais chopper la la shapes("35") ou le 35 eme shape

Bonne remarque ! Faudra donc faire attention dans le nommage des Shapes.

job75 · 28 Juillet 2020

Bonjour,

Ma solution du post #29 semble totalement ignorée :

job75 à dit:
Puisqu'il faut une carte voyez celle-ci qui se colore quand on active la feuille "Carte" :

VB:

Private Sub Worksheet_Activate() Dim s As Shape, c As Range Application.ScreenUpdating = False '---RAZ--- For Each s In Shapes s.Fill.ForeColor.RGB = 16777215 Next '---Couleur--- On Error Resume Next For Each c In Feuil1.PivotTables(1).TableRange1.Columns(1).Cells Set s = Nothing Set s = Shapes("FR-" & IIf(IsNumeric(c), Format(c, "00"), c)) s.Fill.ForeColor.RGB = c(1, 5).DisplayFormat.Interior.Color Next End Sub

Edit : toutes les Shapes sont groupées, pour voir leurs noms (FR-xx) dégroupez-les.

Pourtant elle utilise le dernier fichier déposé par pascaleg80 au post #12.

Et avec DisplayFormat le code est vraiment très simple.

A+

Microsoft 365 Carte de france Dynamique

pascaleg80

XLDnaute Nouveau

Pièces jointes

Dudu2

XLDnaute Barbatruc

Pièces jointes

patricktoulon

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

pascaleg80

XLDnaute Nouveau

patricktoulon

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Discussions similaires