Bulles se positionnent sur une image comme on veut (VBA)

Option Explicit
Sub MatriceDeBulles()

'-----Constantes
Const Destination As String = "D10" 'Cellule de destination de la matrice
Const Couleur As Long = "670343" 'Couleur des bulles
Const Larg As Byte = 10 'Largeur des cellules de la matrice

'-----Variables
Dim Fe As Worksheet
Dim Ech As Double, L As Double, T As Double, W As Double, Largeur As Double
Dim c As Range, v As Range, Plage As Range, Dest As Range
Dim dL As Integer, dC As Integer
Dim Shp As Shape
Set Fe = Worksheets("Feuil1")
Application.ScreenUpdating = False
With Fe
For Each Shp In .Shapes
If Shp.Type = 1 Then Shp.Delete
Next Shp
Set Plage = .Range("B2:B4")
End With

'-----Echelle
Ech = 50 / Application.Max(Plage)
For Each c In Plage
W = Ech * c.Value 'Diametre de la bulle
With ActiveSheet.Shapes(c.Offset(0, -1).Value)
L = .Left + .Width / 2 - W / 2
T = .Top + .Height / 2 - W / 2
End With

'-----Ajout de la bulle
With Fe.Shapes.AddShape(msoShapeOval, L, T, W, W)
.Fill.ForeColor.RGB = Couleur
.Line.ForeColor.RGB = Couleur
End With
Next c
Set Plage = Nothing
End Sub



'-----Suppression des bulles
Private Sub SupShape(ByVal SheetName As String)
Dim Shp As Shape

For Each Shp In Worksheets(SheetName).Shapes
If Shp.Type = 1 Then Shp.Delete
Next Shp
End Sub

Cliquez pour agrandir...