Microsoft 365 Carte Choroplèthe communale

[Eljojo_e]

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]

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

P

 

[Eljojo_e]

Bonjour,
Une méthode possible est de passer par le code Insee sur carte personnalisée comme dans l'exemple joint.
Regarde la pièce jointe 1127975
P

Bonjour, merci pour ta réponse, mais je ne comprends pas comment tu génère la carte sur ton fichier ?

 

[p56]

Pour dessiner une carte j'ai une méthode (qui utilise des données en OpenData)
Lire ici mon article : http://tatiak.canalblog.com/archives/2019/01/03/36988017.html
Quel est le département souhaité?

 

[Eljojo_e]

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

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

 

[p56]

Pas mauvais ce code ... que j'avais écrit il y a déjà qq temps!

 

[Eljojo_e]

Pas mauvais ce code ... que j'avais écrit il y a déjà qq temps!

Ah pas mal^^. Du coup ça m'a bien servi merci

 

[Lolote83]

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]

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

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]

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