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

nabuco

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

Merci tatiak, mais je suis plutôt perdu pour le coup, car il s'agit ici de récupérer une valeur qui est présente dans le tableau des données et ce pour chaque cercle proportionnel (shape?) présent sur la carte. Or il me semble qu'avec cette proposition de ligne de code on vient donc inscrire un texte en l'occurrence "COUCOU" dans un shape mais sans faire référence à la valeur d'une cellule du tableau (désolé je ne suis pas très doué en la matière, plutôt un bidouilleur atardé).
nabuco
 
Dernière édition:

nabuco

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

Waouh, super! c'est exactement çà.
Merci beaucoup et chapeau bas.

Bonne soirée.
:) François
 

PBO229

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

Bonjour à tous,
Géniales vos cartes!
J'ai un peu le même problème que Nabuco et je souhaite afficher sur la carte de France des cercles avec les valeurs dedans.
J'ai donc pris la carte du monde de Tatiak (map(3)) et j'ai collé dans la macro Dept.xls la partie qui me semblait écrire dans les ronds:
With .TextFrame2.TextRange.Characters
.Text = Cells(i + 1, "F").Text
.Font.Size = Int(11 * coef * 1.2)
.Font.Bold = True
End With

J'ai juste changé le "F" par un "L". Mais ça ne marche pas...
Quelqu'un a une idée?

EDIT: Bon j'ai réussi en fait mais ça écrit de haut en bas, une idée pour que ça écrive de gauche à droite?
 
Dernière édition:

PBO229

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

Merci Tatiak, ça fonctionne parfaitement!
Le choix des couleurs de remplissage se fait dans quelle partie de la macro?

Bonne journée
 

PBO229

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

Merci pour le code.
Il y a néanmoins plusieurs choses que je ne comprends pas.
Pourquoi i va de 1 à 9, à quoi est-ce que ça correspond?
Si je veux mettre une condition sur les couleurs: Si la valeur est entre 0 et 10 alors remplir en bleu (par exemple), où est-ce que je peux l'insérer? Il faut que j'affecte une nouvelle valeur à indexcouleur en fonction de la valeur?

Bonne soirée :)
 

PBO229

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

Bonjour à tous,
Merci Tatiak pour ton aide.
J'ai adapté le code grâce à tes explications.
DERLIG ne fonctionne pas, n'est-ce pas comme cela que l'on sélectionne la dernière ligne?
Si je remplace DERLIG par une valeur rien ne se passe, à quoi cela peut-être dû?
Je précise que mes données en L sont des pourcentages.
Code:
Option Explicit

Sub dessin()
Dim i As Integer, coef As Single, DERLIG  As Single

Dim couleur, indexcouleur As Byte

    couleur = Array(RGB(255, 255, 255), RGB(255, 253, 0), RGB(255, 160, 0), _
                RGB(255, 86, 0), RGB(255, 0, 0), RGB(255, 255, 255))
    indexcouleur = 0
   
    On Error Resume Next
DERLIG = .Range("J" & .Rows.Count).End(xlUp).Row
For i = 1 To DERLIG
    Select Case Cells(i + 1, "L").Value
        Case 0 To 0.005: indexcouleur = 1
        Case 0.005 To 0.2: indexcouleur = 2
        Case 0.2 To 0.4: indexcouleur = 3
        Case 0.4 To 0.6: indexcouleur = 4
        Case 0.6 To 1: indexcouleur = 5
        Case Else: indexcouleur = 6
    End Select
        With Shapes("Zone" & Cells(i + 1, "D"))
            .Height = coef * 60
            .Width = coef * 60
            With .TextFrame2.TextRange.Characters
                .Text = Cells(i + 1, "L").Text
                .Font.Size = Int(11 * coef * 1.2)
                .Font.Bold = True
            End With
            .TextFrame2.WordWrap = msoFalse
            .Fill.ForeColor.RGB = couleur(indexcouleur)
        End With
    Next i
End Sub
 
Dernière édition:

PBO229

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

Wahou beau boulot!
J'ai ajouté tous les départements avec leurs préfectures ainsi que les coordonnées GPS.
Je veux bien le partager avec vous mais le fichier est trop volumineux.
Vous pouvez m'envoyer un MP si vous le voulez.
 
Dernière édition:

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:

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.
 

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
 

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
 

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:

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+
 

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas