Discussion :

[brunoaimej]

Bonjour,
Dans le cadre de la rédaction d'un rapport annuel, je dois repérer mes données rapidement sur une carte de France.
J'effectue des visites de sécurité incendie dans des musées de France, et à l'issue j'ai différentes données que je dois répertorier par région et par département (nombre de visite, les avis, s'il existe un système de sécurité incendie...).
J'aimerai rentrer mes éléments sur une base de données, pour qu'elles s'affichent directement sur la carte afin qu'à l'instant T je puisse savoir ou j'en suis..
Je joins le fichier que j'ai trouvé qui se rapproche le plus de ce que je recherche.
Par exemple, au lieu de FR-01, j'aimerai "Ain", une seconde carte par région sur le même principe...
Merci pour votre aide

[mercatog]

Le fichier est déjà prêt, il suffit de sélectionner la carte, de dissocier toutes les shapes, de renommer respectivement chaque shape avec le nom du département.

Attention, cette phase est primordiale et fastudieuse.

Enfin, remplace les codes par ceux-ci (j'ai pas traité l'Ile de France)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
Option Explicit
 
Private Sub BoutonEffacer_Click()
Dim Reponse As Byte
Dim PosCel As Byte
 
Reponse = MsgBox("Voulez-vous vraiment tout effacer?", vbYesNo, "Effacement")
If Reponse = vbYes Then
    Application.ScreenUpdating = False
    For PosCel = 0 To Range(Range("A2"), Range("A2").End(xlDown)).Offset(0, 1).Cells.Count - 1
        Range("B2").Offset(PosCel, 0).ClearContents
    Next PosCel
    '  ThisWorkbook.Sheets(1).Shapes("CarteFrance").Fill.ForeColor.RGB = 16777215    ' Blanc
    Application.ScreenUpdating = True
End If
End Sub
 
Private Sub Worksheet_Change(ByVal Cible As Range)
Dim PlageAutorisee As Range, c As Range
 
Set PlageAutorisee = Range("B2:B" & Range("A2").End(xlDown).Row)
If Not Intersect(Cible, PlageAutorisee) Is Nothing Then
    For Each c In Intersect(Cible, PlageAutorisee)
        Call ColorieDepartement(c)
    Next c
End If
End Sub
 
Private Sub ColorieDepartement(ByVal CelMod As Range)
Dim Sauts As String
Dim Formes As Shape
 
With ThisWorkbook.Sheets(1)
    Sauts = String(CelMod.Offset(0, 1), Chr(13))
    Set Formes = .Shapes(CelMod.Offset(0, -1).Value)
    With Formes
        .Fill.Solid
        .Fill.Transparency = 0#
        .Fill.ForeColor.RGB = CouleurDep(CelMod)
        With .TextFrame2.TextRange
            .Characters.Text = Sauts & CelMod.Value
            .Characters().Font.Size = 8
            .ParagraphFormat.Alignment = msoAlignCenter
        End With
    End With
End With
End Sub
 
Private Function CouleurDep(ByVal CelRef As Range)
 
Select Case Val(CelRef.Value)
    Case 0: CouleurDep = 16777215                  ' Blanc
    Case 0 To 5: CouleurDep = 16777215             ' Blanc
    Case 6 To 10: CouleurDep = 13209               ' Marron
    Case 11 To 20: CouleurDep = 255                ' Rouge
    Case 20 To 30: CouleurDep = 39423              ' Orange
    Case 30 To 40: CouleurDep = 65535              ' Jaune
    Case 40 To 50: CouleurDep = 52749              ' Vert foncé
    Case 50 To 60: CouleurDep = 52377              ' Vert
    Case 60 To 70: CouleurDep = 26637              ' Gris
    Case Else: CouleurDep = 16763904               ' Bleu clair
End Select
End Function

PS: Remplace aussi les bornes pour les couleurs

[brunoaimej]

Bonjour mercatog

Je regarde au plus vite les éléments que tu m'apportes, et je reviens vers toi.
brunoaimej