Discussion :

[la nouvelle]

Bonjour

j'ai décidé de creer un carte interactive de la france. A l'aide de plusieurs tuto j'ai pu le faire. Maintenant j'ai un prolème. J'aimerais colorier ma carte en fonction du CA. j'ai essayé un certain nombre de code mais rien a faire.

S

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
ub colordiff()
For Each Shape In Worksheets("carte").Shapes
For i = 4 To 25
'If
 
If Shape.Name = Worksheets("carte").Range("M" & i).Value Then
Shape.Fill.ForeColor.RGB = RGB(219, 0, 115)
'Shape.Interior.Color = Worksheets("carte").Range("R" & i).Value
'Worksheets("carte").Shapes(Range("M" & i).Value).Fill.ForeColor.RGB = RGB(219, 0, 115)
'Shapes(Range("M5").Value).DrawingObject.Interior.ColorIndex = 13
'ActiveSheet.Shapes(1).DrawingObject.Interior.ColorIndex = 3
End If
Next
'Worksheets("carte").Shapes(Range("K3").Value).Fill.ForeColor.RGB = RGB(0, 0, 255)
Next
End Sub

voici toutes mes tentatives.

J'ai mis le fichir en piece jointe

[boisgontierjacques]

Bonsoir,

Exemple à adapter

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
64
 
Sub EcritRégions()
  For Each c In [régions]
    If c <> "" Then ecritShape c, c
  Next c
End Sub
 
Sub coloriage()
  For Each c In [régions]
   If c <> "" Then
     ca = c.Offset(, 1)
     p = Application.Match(ca, [légende], 1)
     couleur = Range("légende").Cells(p, 1).Interior.Color
     ActiveSheet.Shapes(c).Fill.ForeColor.RGB = couleur
   End If
  Next c
End Sub
 
Sub ecritShape(nomShape, Libellé, Optional posVert, Optional posHoriz)
    Application.Volatile
    With ActiveSheet.Shapes(nomShape).TextFrame2.TextRange
        .Characters.Text = Libellé
        .Characters.Font.Size = 7
        If IsMissing(posVert) Then
          .Parent.VerticalAnchor = msoAnchorMiddle
        Else
          If posVert = "Bas" Then
           .Parent.VerticalAnchor = msoAnchorBottom
          Else
           .Parent.VerticalAnchor = msoAnchorMiddle
          End If
        End If
        If IsMissing(posHoriz) Then
          .Parent.HorizontalAnchor = msoAnchorCenter
        Else
          If posHoriz = "Gauche" Then
           .Parent.HorizontalAnchor = msoAnchorNone
          Else
           .Parent.HorizontalAnchor = msoAnchorCenter
          End If
        End If
     End With
End Sub
 
Sub bulles()
  For Each s In ActiveSheet.Shapes
    If s.Type <> 8 Then
      ActiveSheet.Hyperlinks.Add Anchor:=s, Address:="", SubAddress:=""
      tmp = s.Name
      bulle = Application.VLookup(tmp, [régionsca], 2, False)
      If Not IsError(bulle) Then
         libdep = Application.VLookup(tmp, [régionsca], 1, False)
         s.Hyperlink.ScreenTip = libdep & " Ca:" & Format(bulle, "# ##0") & Chr(10)
      Else
         s.Hyperlink.ScreenTip = "...."
      End If
    End If
  Next s
End Sub
 
Sub maj()
  coloriage
  bulles
End Sub

Boisgontier