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 |
Partager