Carte Choroplèthe communale
Je cherche à faire une carte choroplèthe à l'échelle communale. J'arrive à descendre jusqu'à l'échelle du code postale mais beaucoup de commune ont le même dans mon département.
Possible de le faire ? Car il reconnais pas le code insee ou le nom de commune.
Merci !
Bonjour,
Que vous manque-t-il exactement ? Ce sont les données carto ?
Bonjour, merci pour ta réponse. J'ai un tableau avec des infos : nom commune, code postal, code insee, population etc.. quand je fais insertion=>carte choroplèthe, ca me dessine automatiquement une carte mais ca se passe sur le code postal pas sur l'insee.
Sinon j'ai les coordonnées comme ceci : mais je sais pas comment générer une carte à partir de ca...
[[[7.922524391044095, 45.76000037731076], ....... , 45.76000037731076]]] |
Le code ci-dessous permet de construire les shapes sur l'onglet.
Les couleurs sur la carte vont dépendre de l'ordre de tri du tableau de données. Le code est donc à revoir car il ne correspond pas à ce que vous faites.
Le code utilisé est le suivant :
Option Explicit
Sub Dessin_Carte()
Dim Longitude0 As Double, Latitude0 As Double, Longitude() As Double, Latitude() As Double
Dim I As Integer, J As Long, DerniereLigne As Long
Dim Fin As Byte, Virgule As Byte, Nbpoint As Byte, IndexCouleur As Byte
Dim Ville As String, Dept() As String, S As String, Tablo() As String
Dim Couleur As Variant
Dim ShData As Worksheet, ShCarte As Worksheet
On Error GoTo Fin
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Couleur = Array(RGB(204, 255, 255), RGB(204, 255, 204), RGB(255, 255, 204), RGB(255, 204, 204))
IndexCouleur = 0
Set ShData = Sheets("Data")
Set ShCarte = Sheets("Carte")
With ShData
DerniereLigne = .Cells(.Rows.Count, 1).End(xlUp).Row
ReDim Dept(DerniereLigne)
If DerniereLigne = 1 Then
MsgBox "Pas de données dans l'onglet Data !", vbCritical
GoTo Fin
End If
End With
With ShCarte
Latitude0 = .Range("C2").Value ' 47
Longitude0 = .Range("E2").Value ' -2
End With
For J = 2 To DerniereLigne
Ville = ShData.Cells(J, 3).Value
Dept(J) = ShData.Cells(J, 4).Value
If Dept(J) <> Dept(J - 1) Then
IndexCouleur = IndexCouleur + 1
If IndexCouleur = 4 Then IndexCouleur = 0
End If
S = ShData.Cells(J, 11).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), ".", ","))) * 710
Latitude(Nbpoint) = (Latitude0 - CDbl(Replace(Mid(Tablo(I), Virgule + 1, Fin - Virgule - 1), ".", ","))) * 1000
End If
Next I
With ShCarte.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)
End With
Next J
ShCarte.Range("A1").Select
GoTo Fin
Fin:
Set ShData = Nothing: Set ShCarte = Nothing
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Sub Efface()
Dim Sh As Shape
For Each Sh In Sheets("Carte").Shapes
If (Left(Sh.Name, 6) <> "Bouton") Then Sh.Delete
Next Sh
End Sub
Pour le positionnement de la carte, je fais une extrapolation des coordonnées à partir de ce site : France-lat-long.
Exemple :
- Pour la région Auvergne, Rhône, Alpes, les valeurs sont 47 et -2.
- Pour BZH : 49 et 5,2.