Réaliser une carte de la france à partir d'un tableau excel

PBO229

XLDnaute Nouveau
Re : Réaliser une carte de la france à partir d'un tableau excel

Voilà le fichier!
Juste une chose Tatiak, y aurait-il une commande pour mettre les valeurs affichées au premier plan? Certaines valeurs apparaissent tronquées.
 

Fichiers joints

PBO229

XLDnaute Nouveau
Re : Réaliser une carte de la france à partir d'un tableau excel

Il y avait des erreurs pour certaines villes (fautes aux doublons)
C'est maintenant corrigé dans le fichier ci-joint.
:)
 

Fichiers joints

PBO229

XLDnaute Nouveau
Re : Réaliser une carte de la france à partir d'un tableau excel

Bonjour à tous,
J'ai repris le dernier fichier de Tatiak et j'essaie de colorier les régions selon la moyenne des données rentrées pour les départements.
J'ai réussi à dessiner les préfectures de chaque région et d'afficher la moyenne mais je bloque un peu pour le coloriage...
J'ai un peu bidouiller et j'ai peut-être enlever des choses importantes.
Code:
Sub colorer_reg()
Dim Colorimetre
Dim derlig As Integer, lig As Integer
Dim score As Integer, reg As String

    Colorimetre = Array(RGB(255, 255, 255), RGB(255, 255, 175), RGB(255, 255, 90), _
                RGB(255, 255, 0), RGB(255, 212, 10), RGB(255, 197, 25), _
                RGB(255, 183, 16), RGB(255, 165, 50), RGB(255, 149, 40), _
                RGB(255, 123, 0), RGB(255, 97, 0), RGB(255, 64, 0), _
                RGB(255, 0, 0), RGB(255, 0, 128), RGB(245, 25, 255), _
                RGB(220, 65, 255), RGB(204, 102, 255), RGB(191, 128, 255), _
                RGB(160, 126, 255), RGB(130, 120, 255), RGB(113, 113, 255), _
                RGB(96, 96, 255), RGB(64, 64, 255), RGB(0, 0, 230), _
                RGB(0, 0, 128))
                
    derlig = Sheets("Reg").Range("A" & Rows.Count).End(xlUp).Row
    For lig = 2 To derlig
        reg = Sheets("Reg").Cells(lig, "A").Value
        score = Sheets("Dept").Cells(lig, "D").Value
        If score > 0 Then
            Sheets("Carte").Shapes.Range(Array(reg)).Fill.ForeColor.RGB = Colorimetre(def_color(score))
        End If
    Next lig
End Sub

Sub dessin_reg()
Dim longitude() As Double, latitude() As Double
Dim i As Integer, j As Long
Dim fin As Byte, virgule As Byte, nbpoint As Integer
Dim ville As String, dept() As String, S As String, reg() As String
Dim Sepa As String
Dim tablo() As String
Dim couleur, indexcouleur As Single
Dim Colorimetre
Dim derlig As Integer, lig As Integer
Dim score As Double

    Colorimetre = Array(RGB(255, 255, 255), RGB(255, 255, 175), RGB(255, 255, 90), _
                RGB(255, 255, 0), RGB(255, 212, 10), RGB(255, 197, 25), _
                RGB(255, 183, 16), RGB(255, 165, 50), RGB(255, 149, 40), _
                RGB(255, 123, 0), RGB(255, 97, 0), RGB(255, 64, 0), _
                RGB(255, 0, 0), RGB(255, 0, 128), RGB(245, 25, 255), _
                RGB(220, 65, 255), RGB(204, 102, 255), RGB(191, 128, 255), _
                RGB(160, 126, 255), RGB(130, 120, 255), RGB(113, 113, 255), _
                RGB(96, 96, 255), RGB(64, 64, 255), RGB(0, 0, 230), _
                RGB(0, 0, 128))

    indexcouleur = 0
    Sepa = Application.International(xlDecimalSeparator)

    ReDim dept(Sheets("Data").Range("A65000").End(xlUp).Row)
    
    For j = 2 To Sheets("Data").Range("A65000").End(xlUp).Row
        ville = Sheets("Data").Cells(j, 3).Value
        dept(j) = Sheets("Data").Cells(j, 4).Value
        score = Sheets("Data").Cells(j, 10).Value
        If dept(j) <> dept(j - 1) Then
            indexcouleur = def_color(score)
        End If
            
        S = Sheets("Data").Cells(j, 7).Value & Sheets("Data").Cells(j, 8).Value
        tablo = Split(S, "[")
        ReDim longitude(UBound(tablo))
        ReDim latitude(UBound(tablo))
        nbpoint = 0
        For i = 0 To UBound(tablo)
            fin = InStr(1, tablo(i), "]")
            If fin > 0 Then
                nbpoint = nbpoint + 1
                virgule = InStr(1, tablo(i), ",")
                longitude(nbpoint) = (longitude0 + CDbl(Replace(Mid(tablo(i), 1, virgule - 1), ".", Sepa))) * 46.2 '710
                latitude(nbpoint) = (latitude0 - CDbl(Replace(Mid(tablo(i), virgule + 1, fin - virgule - 1), ".", Sepa))) * 66 '1000
            End If
        Next i
        
        With Sheets("Carte").Shapes.BuildFreeform(msoEditingAuto, longitude(1), latitude(1))
            For i = 2 To nbpoint
                .AddNodes msoSegmentLine, msoEditingAuto, longitude(i), latitude(i)
            Next i
            .AddNodes msoSegmentLine, msoEditingAuto, longitude(1), latitude(1)
            .ConvertToShape.Select
            Selection.Name = dept(j)
            Selection.ShapeRange.Fill.ForeColor.RGB = Colorimetre(indexcouleur)
            Selection.OnAction = "USF"
        End With
    Next j
    Sheets("Carte").Range("A1").Select
End Sub
Sub dessin_pref()
Dim Colorimetre, indexcouleur As Byte, sh As Shape, shTxt As Shape
Dim derlig As Integer, lig As Integer, coef As Single
Dim longitude As Double, latitude As Double
Dim Sepa As String, tablo() As String, txt As Integer, textper As String

    Colorimetre = Array(RGB(255, 255, 255), RGB(255, 255, 175), RGB(255, 255, 90), _
                RGB(255, 255, 0), RGB(255, 212, 10), RGB(255, 197, 25), _
                RGB(255, 183, 16), RGB(255, 165, 50), RGB(255, 149, 40), _
                RGB(255, 123, 0), RGB(255, 97, 0), RGB(255, 64, 0), _
                RGB(255, 0, 0), RGB(255, 0, 128), RGB(245, 25, 255), _
                RGB(220, 65, 255), RGB(204, 102, 255), RGB(191, 128, 255), _
                RGB(160, 126, 255), RGB(130, 120, 255), RGB(113, 113, 255), _
                RGB(96, 96, 255), RGB(64, 64, 255), RGB(0, 0, 230), _
                RGB(0, 0, 128))
                
    For Each sh In Sheets("Carte").Shapes
        If (Left(sh.Name, 1) = "_") Then sh.Delete
    Next sh
    
    Sepa = Application.International(xlDecimalSeparator)
    derlig = Sheets("Reg").Range("A" & Rows.Count).End(xlUp).Row
    For lig = 2 To derlig
        txt = Sheets("Reg").Cells(lig, "D").Value
        textper = Round(Sheets("Reg").Cells(lig, "D").Value, 0) & "%"
        If Not txt = 0 Then
            coef = Sheets("Reg").Cells(lig, "E").Value
            indexcouleur = def_color(txt)
            tablo = Split(Sheets("Reg").Cells(lig, 3).Value, ",")
            latitude = (latitude0 - CDbl(Replace(tablo(0), ".", Sepa))) * 66 ' 1000
            longitude = (longitude0 + CDbl(Replace(tablo(1), ".", Sepa))) * 46.2 ' 710
            Set sh = Sheets("Carte").Shapes.AddShape(msoShapeOval, longitude - 5, latitude - 5, 10, 10)
            With sh
                .Name = "_" & Sheets("Reg").Cells(lig, "B").Value
                .Fill.ForeColor.RGB = Colorimetre(indexcouleur)
                .Line.Weight = 1
                .Height = coef * 50
                .Width = coef * 50
                .OnAction = "USF"
            End With
            Set shTxt = Sheets("Carte").Shapes.AddTextbox(1, longitude - 5, latitude - 5, 40, 25)
            With shTxt
                .Name = "__" & Sheets("Reg").Cells(lig, "B").Value
                With .TextFrame2.TextRange.Characters
                    .Text = textper
                    .Font.Size = 12
                    .Font.Bold = True
                End With
                .Fill.Visible = msoFalse
                .Line.Visible = msoFalse
                .OnAction = "USF"
            End With
        End If
    Next lig
    'For lig = 10 To 34
    '    Sheets("Carte").Cells(lig , "B").Interior.color = Colorimetre(lig - 9)
    'Next lig
    Sheets("Carte").Range("A1").Select
End Sub
EDIT: J'ai créé une feuille reg comme suit et j'ai rajouter les moyennes dans la feuille data:
REG PREF GeoPoint PDM 111,5
ALSACE STRASBOURG 48.583333,7.75 21 0,183856502
AQUITAINE BORDEAUX 44.833333,-0.566667 24 0,215246637
 
Dernière édition:

tatiak

XLDnaute Barbatruc
Re : Réaliser une carte de la france à partir d'un tableau excel

Oulà Kestufé? :confused: Tu n'as pas besoin de modifier quoi que ce soit!!
Dans le fichier France_Clients3.xlsm, il te suffit de saisir tes données relatives aux départements dans l'onglet "Dept", puis de cliquer sur le bouton "2 - Colorer départements"
 

PBO229

XLDnaute Nouveau
Re : Réaliser une carte de la france à partir d'un tableau excel

Bonjour à tous,
Pauvre Tatiak, cela doit te faire quelque chose de voir ton code malmené de la sorte.
La partie pour colorer les départements marche niquel.
Ce que je veux faire c'est colorer région par région selon la moyenne des valeurs des départements qui la composent.
J'ai donc repris ta procédure pour dessiner la carte de France (car c'était elle qui colorait, il me semble, les régions en nuances de gris) et j'ai essayé de faire ce que je voulais à partir de ça.
La procédure dessin_pref marche bien, elle dessine les préfectures régionales selon la moyenne de la région.
 

tatiak

XLDnaute Barbatruc
Re : Réaliser une carte de la france à partir d'un tableau excel

Dans ce cas, dans l'onglet "Dept":
* tu classes la liste par région
* tu indiques les chiffres de chaque département dans une nouvelle colonne, par exemple en G
* tu ajoutes en colonne E des formules de moyenne du genre =MOYENNE(G$4:G$8) sur chaque ligne de département
et basta, il reste à cliquer sur le bouton "2 - Colorer départements"

En plus, cette solution simple permettra une mise à jour rapide quand les "nouvelles régions" seront effectives.
 

tatiak

XLDnaute Barbatruc
Re : Réaliser une carte de la france à partir d'un tableau excel

Ok, parfait.
En fait en nettoyant bien le fichier et en le comprimant on arrive à le poster ici.
:) Pierre
 

Fichiers joints

PBO229

XLDnaute Nouveau
Re : Réaliser une carte de la france à partir d'un tableau excel

Bonjour à tous,
Est-il possible d'ajouter à la carte les Dom-Tom?
Tatiak, je veux bien m'en occuper mais quelques explications/pistes me seraient bien utiles :)
Bonne journée
 

tatiak

XLDnaute Barbatruc
Re : Réaliser une carte de la france à partir d'un tableau excel

Bonjour,

Avec le principe retenu dans la démo précédente, il est possible de dessiner tout territoire existant, tant qu'on dispose de ses coordonnées GPS.
Néanmoins, il faut garder en tête que le principe ici est de fixer une latitude et une longitude données au coin supérieur gauche de la feuille XL.
La carte se dessinera en fonction de cette référence.
Pour avoir la métropole et des DOM-TOM sur la même carte, le contour de la métropole et les contours des DOM-TOM seront donc aussi éloignés qu'en réalité (à l'échelle du dessin bien sûr)

S'il s'agit toujours de visualiser des "scores" sur une carte, pour ce besoin, autant passer à l'échelle "Monde" avec un outil plus simple du genre du fichier joint (dans lequel tu replaceras les shapes "ronds" à l'endroit que tu veux).

:) Pierre
 

Fichiers joints

PBO229

XLDnaute Nouveau
Re : Réaliser une carte de la france à partir d'un tableau excel

Ok merci, je comprends mieux comment marche la macro
Un peu compliqué pour les DOM-TOM alors.
Un agrandissement de l'île de France doit être assez simple par contre.
Est-ce que changer les multiplicateurs ici, dans la sub dessin peut marcher?
Code:
                longitude(nbpoint) = (longitude0 + CDbl(Replace(Mid(tablo(i), 1, virgule - 1), ".", Sepa))) * 46.2 '710
                latitude(nbpoint) = (latitude0 - CDbl(Replace(Mid(tablo(i), virgule + 1, fin - virgule - 1), ".", Sepa))) * 66
 

PBO229

XLDnaute Nouveau
Re : Réaliser une carte de la france à partir d'un tableau excel

Bonjour à tous,

Est-ce qu'il existe une méthode pour enregistrer la carte au format image?
Quand je sélectionne les cellules pour faire un collage spécial il n'y a que le fond de carte (sans les cercles) qui apparait.

Merci à vous
 

tatiak

XLDnaute Barbatruc
Re : Réaliser une carte de la france à partir d'un tableau excel

Sous Windows 8 Outil Capture d'écran ou outil équivalent pour les autres versions
 

david84

XLDnaute Barbatruc
Re : Réaliser une carte de la france à partir d'un tableau excel

Bonjour Pierre,

j'ai regardé ton fichier très sympa du message #50.

Ci-joint une petite contribution : plutôt que de cliquer sur le shape du département pour afficher son nom il peut être préférable d'avoir cette information au survol de la souris sur le shape.

Pour cela tu peux créer dans la Sub dessin_carte des Hyperliens associés aux shapes lors de leur création.
L'astuce consiste à utiliser l'argument ScreenTip de la propriété HyperLinks pour afficher cette information.
De plus tu peux également en cliquant dessus afficher le département dans Google Map :
Code:
       With Sheets("Carte").Shapes.BuildFreeform(msoEditingAuto, longitude(1), latitude(1))            
            For i = 2 To nbpoint
                .AddNodes msoSegmentLine, msoEditingAuto, longitude(i), latitude(i)
            Next i

            .AddNodes msoSegmentLine, msoEditingAuto, longitude(1), latitude(1)
            .ConvertToShape.Select
            Selection.Name = ville
            Selection.ShapeRange.Fill.ForeColor.RGB = couleur(indexcouleur)
            
            'création du lien hypertext permettant :
            '- l'affichage du nom du département au survol de la souris (+ la région pour l'exemple)
            '- l'affichage du département dans Google Map lorsque l'on clique dessus
            .Application.ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), _
            Address:="https://www.google.fr/maps/place/" & ville, _
            ScreenTip:=ville & vbCrLf & Sheets("Data").Cells(j, 4)
            
            'OnAction devient inopérant si l'on utilise un Hyperlien
            'Selection.OnAction = "USF"
        End With
Un bémol toutefois : la propriété OnAction devient alors inopérante : il faut donc choisir entre les 2 possibilités (ou alors peut-être remplacer dans l'argument "Address" de Hyperlinks le lien vers Google Maps par un lien vers un fichier vbscript qui lancerait une procédure similaire à celle placée dans "USF" mais c'est juste une idée car je n'ai pas testé et donc je ne sais pas si c'est jouable).

Enfin bon c'est juste une idée en passant...

A+
 
Dernière édition:

tatiak

XLDnaute Barbatruc
Re : Réaliser une carte de la france à partir d'un tableau excel

Bonjour David,

Tout à fait intéressante cette idée! :)

Pour combiner effet "Rollover" et affichage d'info, on peut faire pointer le lien vers une ligne correspondant au numéro de département :
Code:
.Application.ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), _
Address:="", SubAddress:=Sheets("Carte").Name & "!A" & j, _
ScreenTip:=Sheets("Data").Cells(j, 4) & vbCrLf & Sheets("Data").Cells(j, 3)
Ce qui permet de récupérer le numéro de la ligne avec l'évènement SelectionChange, et donc d'afficher l'info correspondant au département
Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim derlig As Integer, lig As Integer
    With Sheets("Dept")
        derlig = .Range("A" & Rows.Count).End(xlUp).Row
        If Not Intersect(Target, Range("A2:A" & derlig)) Is Nothing And Target.Count = 1 Then
            lig = Application.Match(Sheets("Data").Cells(Target.Row, 6), .Columns(1), 0)
            Application.EnableEvents = False
            Range("A1").Select
            MsgBox .Cells(1, 5) & vbCrLf & .Cells(lig, 5), , .Cells(lig, 2)
            Application.EnableEvents = True
        End If
    End With
End Sub
Qu'en penses-tu?
:) Pierre
 

Fichiers joints

Dernière édition:

david84

XLDnaute Barbatruc
Re : Réaliser une carte de la france à partir d'un tableau excel

Bonjour,

Qu'en penses-tu?
Super idée !

Fais attention cependant car dans le Worksheet_SelectionChange la variable derlig pointe sur la feuille "Dept".
Or comme celle-ci a moins de lignes que la feuille Data cela ne fonctionne pas lorsque tu cliques sur certains départements placés après la ligne 97 de la feuille Data (Vendée ou Bouches du Rhône par exemple).

Je pense qu'en pointant cette variable sur la feuille Data cela fonctionne (à vérifier de ton côté):
Code:
derlig = Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row
A+
 

Discussions similaires


Haut Bas