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

marin

XLDnaute Nouveau
Bonjour à tous,

Je dois réaliser à partir de ma donnee source une carte de la france.

je vous joins le fichier avec ma donnée source. Je souhaite mettre sur une carte de France des ronds ou barres proportionnelles avec la somme du chiffre d'affaire hors taxe correspondant à chaque département.

est-il possible de le faire sous excel 2010? comment puis-je le réaliser?

Merci d'avance pour vos réponses

Marine
 

Pièces jointes

  • test carte géo france.xlsx
    11.1 KB · Affichages: 3 854

hicks007

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

bon voici mon fichier finaliser, mais qui ne fonctionne toujours pas.
j'ai modifié la macro pour remplacer "dept+n°" par "cp+n°". j'ai fait ma liste de code postaux, j'ai mis ne face des chiffres hypothétique, j'ai placé mes petits rond partout sur ma carte et je les ais nommés. ex : melun 77000 = cp77000
mais les ronds me regardent fixement :confused:
qu'ai je loupé ?

serait ce la taille de mes bulles non identiques a la base ?
 

Pièces jointes

  • Copie de Dept.xls
    651.5 KB · Affichages: 206
Dernière édition:

JCGL

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

Bonjour à tous,

Il manquait une formule en I (colonne masquée)

A+ à tous
 

Pièces jointes

  • JC Copie de Dept (2).xls
    767.5 KB · Affichages: 179

nabuco

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

Bonjour à tous,

Super c'est exactement ce que je recherchais pour le transposer à une carte monde.
Par contre y aurait-il une astuce pour intégrer la valeur des données à l'intérieur des cercles proportionnés?
Au départ j'ai pensé faire un collage spécial par image liées des données mais ce n'est pas top au niveau présentation.

J'ai rencontré également un souci lorsque j'ai tenté de renommer dans la macro le "dept" par "zone", à chaque fois la macro devenait inopérante. De même impossible de renommer les objets cercles (Dept01, etc...) en faisant Ctrl + clic sur le cercle puis en renommant et entrée à chaque fois le nom précédent réapparaît.

Pouvez vous m'éclairer de vos lumières?

Merci d'avance

Ci-joint ma maquette
 

Pièces jointes

  • map.xls
    96.5 KB · Affichages: 80

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:

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 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.
 

Pièces jointes

  • villes_gps.xlsx
    13.3 KB · Affichages: 60

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.
:)
 

Pièces jointes

  • villes_gps.xlsx
    13.5 KB · Affichages: 68

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:

Discussions similaires

Réponses
29
Affichages
1 K

Statistiques des forums

Discussions
311 709
Messages
2 081 779
Membres
101 816
dernier inscrit
Jfrcs