Carte Choroplèthe communale

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

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.

Génial merci !