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
78
79
80
81
82
83
84
85
|
Option Explicit
Sub essai()
Dim Fe As Worksheet
Dim Ech As Double, L As Double, T As Double, W As Double
Dim Cel As Range
Dim Shp As Shape
Dim Ch As OLEObject
Dim j As Long
Dim an As String
Dim I As Integer, Indice As Integer
Dim Tablo
Application.ScreenUpdating = False
Set Fe = Worksheets("Data")
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 la colonne 5 (E)
Ech = 15 / Application.Max(.ListObjects(1).ListColumns(5).Range)
End With
With Sheets("MAP")
.Select
' On efface tous les cercles
For Each Shp In .Shapes
Debug.Print Shp.Type, Shp.Name, Shp.TopLeftCell.Address, Shp.Left, Shp.Top
If Shp.Type = 1 Then Shp.Delete
Next Shp
' On passe en revue les CheckBox
ReDim Tablo(0 To 4, 0 To Indice)
For Each Ch In .OLEObjects
If Ch.Name Like "CheckBox*" Then
If Ch.Object.Value = True Then
an = Ch.Object.Caption
For Each Cel In Fe.ListObjects(1).ListColumns(6).Range
If Cel = an Then
For I = 0 To Indice - 1
If Tablo(0, I) = Cel.Offset(0, -5) Then '
Tablo(4, I) = Tablo(4, I) + Cel.Offset(0, -1)
Exit For
End If
Next I
If I = Indice Then
ReDim Preserve Tablo(0 To 4, 0 To Indice)
Tablo(0, Indice) = Cel.Offset(0, -5) '
Tablo(1, Indice) = Cel.Offset(0, -4) ' Nom de la forme
Tablo(2, Indice) = Cel.Offset(0, -3) ' L
Tablo(3, Indice) = Cel.Offset(0, -2) ' T
Tablo(4, Indice) = Cel.Offset(0, -1) ' Taille
Indice = Indice + 1
End If
End If
Next Cel
End If
End If
Next Ch
If Indice > 0 Then
For I = 0 To Indice - 1
W = Ech * Tablo(4, I) ' Diametre de la bulle
With .Shapes(Tablo(1, I)) ' Nom de la forme
L = .Left + Tablo(2, I) ' + .Width / 2 - W / 2 ' Position Gauche
T = .Top + Tablo(3, I) '+ .Height / 2 - W / 2 ' Position Haute
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
Next I
End If
End With
End Sub |
