Discussion :

[awa123]

Bonjour,

j'essaye de combiner les codes des deux fichiers en pièce jointes (cf. pièces jointes) pour que les bulles qui sont générées ne se place plus dans la matrcie mais viennent se positionner directement sur les shapes (centré).

voir l'illustration en pièce jointe.

Merci Beaucoup!!

code pour generer les bulles et les placer dans la matrice

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
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 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
 
Application.ScreenUpdating = False
With Worksheets("Feuil1")
    SupShape .Name
    Set Plage = .Range("A1").CurrentRegion
    Set Dest = .Range(Destination)
    Plage.Rows(1).Copy Dest
    Plage.Columns(1).Copy Dest
    dL = Dest.Row - 1
    dC = Dest.Column - 1
    Set Dest = Nothing
 
    Set Plage = Plage.Offset(1, 1).Resize(Plage.Rows.Count - 1, Plage.Columns.Count - 1)
    '-----Préparation de la matrice
    With Plage.Offset(dL, dC)
        .ColumnWidth = Larg
        Largeur = .Cells(2, 2).Width
        .RowHeight = Largeur
    End With
    '-----Echelle
    Ech = (Largeur - 5) / Application.Max(Plage)
    For Each c In Plage
        Set v = c.Offset(dL, dC)
        W = Ech * Val(c.Value)                     'Diametre de la bulle
        L = v.Left + (Largeur - W) / 2             'Gauche
        T = v.Top + (Largeur - W) / 2              'Haut
        Set v = Nothing
        '-----Ajout de la bulle
        With .Shapes.AddShape(msoShapeOval, L, T, W, W)
            .Fill.ForeColor.RGB = Couleur
            .Line.ForeColor.RGB = Couleur
            '            .TextFrame2.TextRange.Characters.Text = Int(c.Value)
        End With
    Next c
    Set Plage = Nothing
End With
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

code pour centrer les bulles dans les shapes

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
Sub test2()
    Dim Sh As Shape
    Set Sh = ActiveSheet.Shapes("Ellipse 2")
    With ActiveSheet.Shapes("Freeform 359")
        Sh.Left = .Left + .Width / 2 - Sh.Width / 2
        Sh.Top = .Top + Sh.Height / 2 + Sh.Height / 2
    End With
End Sub