Changer la couleur d'un point sur un mapping

**Alexandre60300** · 30/11/2018, 09h58

Bonjour à vous!

D'abord je me présente, je viens de m'inscrire sur le site afin d'améliorer mes compétences sur Excel

Je suis Alexandre, je viens d'avoir 25 ans et je viens de signer mon premier CDI après 5 années d'études dans le Marketing.

Je viens vers vous car j'ai un petit soucis, actuellement je réalise un mapping pour le travail. Je me suis servit d'un Template sur internet afin de le réaliser.
En soit j'ai juste modifié/adapté le document par rapport à mes besoins...
Il s'agir d'un mapping de la France, et avec la localisation de chaque transporteurs

Je souhaiterais modifier la couleurs des points les transporteurs:
Transdev -> Rouge
Ratp -> Vert
Kéolis -> Bleu

Actuellement ils sont tous en rouge, et ca me permettrait d'avoir une meilleure visibilité de les avoir en différentes couleurs.

Ci-dessous voici le code VBA pour les points :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Sub dessin_POI()
Dim sh As Shape, derlig As Integer, lig As Integer, T As Variant
Dim longitude As Double, latitude As Double
Dim Sepa As String, tablo() As String, txt As String
 
    For Each sh In Sheets(Carte).Shapes
        If (Left(sh.Name, 1) = "_") Then sh.Delete
    Next sh
    T = Get_List_POI(Sheets(Carte).ComboBox1.Value)
 
    Sepa = Application.International(xlDecimalSeparator)
    For lig = 1 To UBound(T)
        txt = T(lig, 0)
        If Not txt = "" Then
            tablo = Split(T(lig, 1), ",")
            longitude = (longitude0 + CDbl(Replace(tablo(1), ".", Sepa))) * 46.2 * Echelle
            latitude = (latitude0 - CDbl(Replace(tablo(0), ".", Sepa))) * 66 * Echelle
            Set sh = Sheets(Carte).Shapes.AddShape(msoShapeOval, longitude - 5, latitude - 5, 8, 8)
            With sh
                .Name = "_" & txt
                .Fill.ForeColor.RGB = RGB(255, 80, 80)
                .Line.Weight = 1
                .OnAction = "USF"
            End With
        End If
    Next lig
    Sheets(Carte).Range("A1").Select
End Sub

J'essaye depuis hier, mais je n'y arrive pas..
Que faut-il faire s'il vous plait pour intégrer d'autres couleurs ?
Je vous remercie d'avance pour votre aide

Bonne journée !

**ARTURO83** · 30/11/2018, 10h17

Bonjour,

Rajoutez ceci et essayez

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
    For Each sh In Sheets(Carte).Shapes
        If sh.Name = "Transdev" Then
            sh.Fill.ForeColor.RGB = RGB(255, 0, 0)
        ElseIf sh.Name = "Ratp" Then
            sh.Fill.ForeColor.RGB = RGB(0, 255, 0)
        ElseIf sh.Name = "Kéolis" Then
            sh.Fill.ForeColor.RGB = RGB(0, 0, 255)
        End If
    Next sh

Cdlt

**Alexandre60300** · 30/11/2018, 10h40

Merci pour votre réponse, cependant cela ne fonctionne toujours pas..

Je met ici le fichier excel pour que cela soit un peu plus claire de ma part

Mapping Exploitants V2.xlsm

**ARTURO83** · 30/11/2018, 11h06

cela ne fonctionne toujours pas Evidemment que cela ne fonctionne pas, il n'apparaît nulle part les noms des sociétés, toutes les "shapes" commencent par"_" suivi du nom de la ville. Vous pouvez les distinguer les unes des autres en mettant un l'initiale du transporteur devant le "_" .
Exemple:
"R_Châteaudun" pour RATP
"T_Vannes" pour Transdev
"K_Lorient" pour Kéolis
Il ne reste plus qu'à tester le premier caractère de gauche

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
    For Each sh In Sheets(Carte).Shapes
        If left(sh.Name,1) = "T" Then
            sh.Fill.ForeColor.RGB = RGB(255, 0, 0)
        ElseIf left(sh.Name,1) = "R" Then
            sh.Fill.ForeColor.RGB = RGB(0, 255, 0)
        ElseIf left(sh.Name,1) = "K" Then
            sh.Fill.ForeColor.RGB = RGB(0, 0, 255)
        End If
    Next sh

Cdlt

**Alexandre60300** · 30/11/2018, 11h30

Désole je suis novice, j’ai dut mal à tout assimiler, je test après et je reviens vers vous!
Merci déjà pour votre aide et explications !

**Theze** · 30/11/2018, 12h17

Bonjour,

En fait, c'est un peu plus complexe que ça !
Tout d'abords, dans la requête il faut ajouter le champ "Groupe" de façon à récupérer les divers transporteurs

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
 
Function Get_List_POI(Cat As String) As Variant
Dim Requete As String, lig As Long
 
    Get_List_POI = Array("")
 
    Requete = "SELECT Ville, Groupe, Points_GPS " & " FROM [" & Contacts & "$]  " & " WHERE Actif='Actif'" '<--- rajout du champ "Groupe"
 
    If Not Cat = "Tous" Then Requete = Requete & " AND Catégorie ='" & Cat & "'"
 
    lig = SQL.Query(Requete)
 
    If lig > 0 Then Get_List_POI = StRcd
 
End Function

Ensuite, il faut modifier au niveau du tableau dans la procédure "dessin_POI()" ci-dessous, de façon à récupérer les noms des transporteurs pour comparer et colorer :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
 
Sub dessin_POI()
 
Dim sh As Shape, derlig As Integer, lig As Integer, T As Variant
Dim longitude As Double, latitude As Double
Dim Sepa As String, tablo() As String, txt As String
 
    T = Get_List_POI(Sheets(Carte).ComboBox1.Value)
 
    Sepa = Application.International(xlDecimalSeparator)
    For lig = 1 To UBound(T)
        txt = T(lig, 0)
        If Not txt = "" Then
            tablo = Split(T(lig, 2), ",") '<--- ici, déplacement d'une colonne (2 au lieu de 1)car dans la 1 il y a maintenant les transporteurs
            longitude = (longitude0 + CDbl(Replace(tablo(1), ".", Sepa))) * 46.2 * Echelle
            latitude = (latitude0 - CDbl(Replace(tablo(0), ".", Sepa))) * 66 * Echelle
            Set sh = Sheets(Carte).Shapes.AddShape(msoShapeOval, longitude - 5, latitude - 5, 8, 8)
            With sh
                .Name = "_" & txt
                Select Case T(lig, 1) '<--- ici, dans le tableau se trouve les noms des divers transporteurs Attention de bien orthographier les noms !
                    Case "Transdev": sh.Fill.ForeColor.RGB = RGB(255, 0, 0)
                    Case "Ratp Dev": sh.Fill.ForeColor.RGB = RGB(0, 255, 0)
                    Case "Kéolis": sh.Fill.ForeColor.RGB = RGB(0, 0, 255)
                End Select
 
                .Line.Weight = 1
                .OnAction = "USF"
 
            End With
        End If
    Next lig
    Sheets(Carte).Range("A1").Select
End Sub

Changer la couleur d'un point sur un mapping [XL-2016]

Macros et VBA Excel

Vue hybride

Partager

Partager