[XL-2007] Garder toujours un seul cercle VBA

1 pièce(s) jointe(s)

Garder toujours un seul cercle VBA

Bonjour,

j'ai un fichier qui contient 2 feuilles :

Une feuille 'donnee' qui contient le nom des différentes villes associés à une date (colonne F).
Ainsi dans la feuille 'carte' j'ai mis une carte de la france avec les checkbox nommé '2012' , 'present' et ‘2013’ qui consistent à générer un cercle représentant la ville en question. ( la colonne 'E' représente la taille du cercle.)

le Probleme est que si je met la même ville dans la feuille ‘donnee’ associé à des date différentes, cela va me générer des cercles différents superposés correspondants à leur date associés.

Est il donc possible que lorsqu’il y a la même ville à des dates différentes cela me génère toujours un seul cercle qui va prendre comme taille la somme des valeurs des cases cochés.
quel code peut on rajouter pour prendre en compte cette contrainte?

Cf. illustration dans le fichier joint svp.

Merci

Bonjour,

C'est une belle réalisation sous Excel :ccool:

Il faut structurer le programme différemment :
- toujours conserver le tableau de données trié par ville !
- faire une première boucle sur ce tableau de données
Pour chaque ligne :
1. si la checkbox correspondante (année) est cochée (passer en revue les checkbox), incrémenter une variable TailleTotale
2. si la ligne suivante du tableau concerne une ville différente et que TailleTotale>0, dessiner le cercle puis passer TailleTotale à 0

Voilà, il n'y a plus qu'à ! Bon courage ;)

Voici ce que donne le code modifié :

Code:

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
65
66
67
68
69
70
71
72
73
74
75
76
77
Sub essai()
    Dim Fe As Worksheet
    Dim Ech As Double, L As Double, T As Double, W As Double
    Dim Ligne As ListRow
    Dim Shp As Shape
    Dim Ch As OLEObject
    Dim j As Long
    Dim Checked As New Collection
    Dim TailleTotale As Integer
 
 
 
  Application.ScreenUpdating = False
 
  Set Fe = Worksheets("donnee")
 
  With Fe
    ' On supprime les lignes sans données dans la liste
    For j = .ListObjects(1).ListRows.Count To 1 Step -1
      If Application.CountA(.ListObjects(1).ListRows(j).Range) = 0 Then
        .ListObjects(1).ListRows(j).Delete
      End If
    Next j
 
    ' Calcul de l'échelle avec al colonne 5 (E)
    Ech = 50 / Application.Max(.ListObjects(1).ListColumns(5).Range)
  End With
 
  With Sheets("carte")
    .Select
    ' On efface tous les cercles
    For Each Shp In .Shapes
      If Shp.Type = 1 Then Shp.Delete
    Next Shp
 
    ' On passe en revue les CheckBox et on alimente la collection Checked
    For Each Ch In .OLEObjects
      If Ch.Name Like "CheckBox*" Then
          Checked.Add Ch.Object.Value, Ch.Object.Caption
      End If
    Next Ch
 
    If Checked.Count > 0 Then
 
        TailleTotale = 0
        'On parcourt le tableau de données
        For Each Ligne In Fe.ListObjects(1).ListRows
            If Checked.Item("" & Ligne.Range(1, 6) & "") Then
                'Si la ligne correspond à une année "cochée"
                TailleTotale = TailleTotale + Ligne.Range(1, 5)
            End If
 
            'Avant de changer de ville, on dessine le cercle (si nécessaire)
            If Ligne.Range(2, 1) <> Ligne.Range(1, 1) And TailleTotale > 0 Then
 
                W = Ech * TailleTotale                                  ' Diametre de la bulle : Colonne E
                With .Shapes(Ligne.Range(1, 2).Value)                   ' Colonne B
                  L = .Left + Ligne.Range(1, 3) + .Width / 2 - W / 2    ' Colonne C
                  T = .Top + Ligne.Range(1, 4) + .Height / 2 - W / 2    ' Colonne D
                End With
 
                '-----Ajout de la bulle
                With .Shapes.AddShape(msoShapeOval, L, T, W, W)
                  .Fill.ForeColor.RGB = RGB(0, 32, 96)
                  .Line.ForeColor.RGB = RGB(0, 32, 96)
                End With
 
                TailleTotale = 0
            End If
        Next
 
    End If
 
  End With
 
  Application.ScreenUpdating = True
End Sub

En prérequis : le tableau doit être trié par ville (ou ajouter ce tri dans la procédure)

merci beaucoup