Microsoft 365 Carte Choroplèthe communale

Eljojo_e

XLDnaute Nouveau
BOnjour,
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.
Possible de le faire ? Car il reconnais pas le code insee ou le nom de commune.
Merci !
 

p56

XLDnaute Occasionnel
Bonjour,
Une méthode possible est de passer par le code Insee sur carte personnalisée comme dans l'exemple joint.
Démo_Yvelines.gif

P
 

Pièces jointes

  • Yvelines.xlsm
    168.8 KB · Affichages: 16

Eljojo_e

XLDnaute Nouveau
Bonjour, J'ai réussi à me débrouiller avec ce code :

VB:
Option Explicit

Public Const latitude0 = 45.14
Public Const longitude0 = -5.2
Public Const Echelle = 8
 
    
Sub USF(Optional X As Byte)
Dim code As String, lig As Integer
Dim S As String

    code = Application.Caller
    With Sheets("Data")
        lig = Application.Match(code, .Columns(3), 0)
        S = .Cells(lig, "B") & " - " & .Cells(lig, "C") & vbCrLf & "Adhérents= " & .Cells(lig, "G")
        MsgBox S, , "Canton : " & .Cells(lig, "D")
    End With
End Sub


Sub colorer_zone()
Dim Colorimetre
Dim couleur As Long, Rouge As Integer, Vert As Integer, Bleu As Integer
Dim derlig As Integer, lig As Integer
Dim zone As String, score As Integer

    'Colorimetre = Array(RGB(255, 255, 224), RGB(255, 255, 0), RGB(255, 224, 0), _
    '            RGB(255, 192, 0), RGB(255, 160, 0), RGB(255, 128, 0), _
    '            RGB(255, 96, 0), RGB(255, 64, 0), RGB(255, 32, 0), _
    '            RGB(192, 32, 0))
                
    With Sheets("Data")
        derlig = .Range("A" & Rows.Count).End(xlUp).Row
        For lig = 2 To derlig
            zone = .Cells(lig, "C").Value
            score = .Cells(lig, "G").Value
            If score > 0 Then
                'Sheets("Carte").Shapes.Range(Array(zone)).Fill.ForeColor.RGB = Colorimetre(def_color(score))
                couleur = Sheets("Carte").Cells(26 - def_color(score), "B").Interior.Color
                Rouge = Int(couleur Mod 256)
                Vert = Int((couleur Mod 65536) / 256)
                Bleu = Int(couleur / 65536)
                Sheets("Carte").Shapes.Range(Array(zone)).Fill.ForeColor.RGB = RGB(Rouge, Vert, Bleu)
            End If
        Next lig
    End With
End Sub


Sub dessin_carte()
Dim couleur, indexcouleur As Byte, C As Variant
Dim Sepa As String, dept() As String, ville As String
Dim lig As Integer, i As Integer, j As Long
Dim longitude() As Double, latitude() As Double
Dim S As String, tablo() As String
Dim nbpoint As Byte, fin As Byte, virgule As Byte
Dim Xmin As Double, Xmax As Double, Ymin As Double, Ymax As Double
Dim shTxt As Object

    'couleur = Array(RGB(204, 255, 255), RGB(204, 255, 204), RGB(255, 255, 204), RGB(255, 204, 204))
    
    'couleur = Array(RGB(188, 207, 250), RGB(152, 212, 200), RGB(146, 213, 76), _
                    RGB(227, 246, 141), RGB(245, 225, 110), RGB(250, 196, 0), _
                    RGB(255, 136, 16), RGB(254, 0, 0), RGB(194, 0, 0))
    
    couleur = Array(RGB(240, 240, 240), RGB(220, 220, 220), RGB(200, 200, 200), _
                RGB(180, 180, 180), RGB(160, 160, 160), RGB(140, 140, 140), _
                RGB(120, 120, 120), RGB(100, 100, 100), RGB(90, 90, 90), _
                RGB(256, 256, 256))
                
    indexcouleur = 0
    Sepa = Application.International(xlDecimalSeparator)
    lig = Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row
    ReDim dept(lig)
    
    For j = 2 To lig
        ville = Sheets("Data").Cells(j, "C").Value
        dept(j) = Sheets("Data").Cells(j, "D").Value
        If dept(j) <> dept(j - 1) Then
            indexcouleur = indexcouleur + 1
            If indexcouleur = UBound(couleur) + 1 Then indexcouleur = 0
        End If
        S = Sheets("Data").Cells(j, "E").Value
        tablo = Split(S, "[")
        ReDim longitude(UBound(tablo))
        ReDim latitude(UBound(tablo))
        nbpoint = 0
        Xmin = 2000
        Ymin = 2000
        Ymax = 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))) * 44.4 * Echelle
                latitude(nbpoint) = (latitude0 - CDbl(Replace(Mid(tablo(i), virgule + 1, fin - virgule - 1), ".", Sepa))) * 67.5 * Echelle
                If longitude(nbpoint) < Xmin Then Xmin = longitude(nbpoint)
                If latitude(nbpoint) < Ymin Then Ymin = latitude(nbpoint)
                If latitude(nbpoint) > Ymax Then Ymax = latitude(nbpoint)
            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 = ville
            Selection.ShapeRange.Fill.ForeColor.RGB = couleur(indexcouleur)
            Selection.OnAction = "USF"
        End With
        
        Set shTxt = Sheets("Carte").Shapes.AddTextbox(1, Xmin, Ymin - 6 + (Ymax - Ymin) / 2, 50, 20)  'Set shTxt = Sheets("Carte").Shapes.AddTextbox(1, Xmin, Ymin - 6 + (Ymax - Ymin) / 2, 40, 10)
        With shTxt.TextFrame2.TextRange.Characters
            .Text = ville
            .Font.Size = 6
        End With
        shTxt.Fill.Visible = msoFalse
        shTxt.Line.Visible = msoFalse
        shTxt.Name = ville
        shTxt.OnAction = "USF"
    Next j
    Sheets("Carte").Range("A1").Select
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


Function def_color(score As Integer) As Byte
    def_color = 0
    If score > 0 And score <= 100 Then def_color = Int(score / 10)
End Function
 

Lolote83

XLDnaute Barbatruc
Bonjour à tous, @Tatiak,
Je me permet de rejoindre le fil car malgré mes visites sur ton site, les différentes explications, je n'arrive pas à intégrer ma carte du VAR (83)
Je souhaite donc une carte des communes du var et si c'est pas trop demandé, celle des alpes maritimes (06), de façon a déterminer en fonction d'une commune, celles qui sont limitrophes.
J'espère que ma requête trouvera réponse positive.
Cordialement
@+ Lolote83
 

p56

XLDnaute Occasionnel
Bonjour Lolote,
Pas de souci! Voici une carte du Var + Alpes Maritimes à télécharger (depuis mon site car fichier trop gros pour ici) =>Lien pour téléchargement carte du Var+Alpes Maritimes

Capture d’écran 2022-02-06 115557.gif

C'est une carte simple sans beaucoup de code, juste un RAZ pour colorer les 2 départements avec 2 couleurs différentes pour pouvoir les distinguer, et un zoom +/- pour ajuster la taille de la carte.
Sur la carte, chaque commune est identifiée par son n° INSEE, un clic sur une forme pour afficher de l'info
+ la liste des communes en "Bdd", pour utilisation ultérieure.
C'est juste une base de travail, je peux fournir du code spécifique en fonction de votre besoin.
Bon dimanche
P.
 

Lolote83

XLDnaute Barbatruc
Bonjour Tatiak.
Un grand merci déjà pour ceci.
Je vais voir ce que je peux faire avec et éventuellement je reviendrais vers toi si plus de besoin.
Mais bon sang, comment fais tu ceci. J'ai regardé pas mal de tuto pour obtenir cette "&#@!! de carte et rien de concret.
Bon dimanche
@+ Lolote83
 

Discussions similaires

Statistiques des forums

Discussions
299 706
Messages
1 978 624
Membres
206 311
dernier inscrit
koumb