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

[Theze]

Bonjour,

Teste et adapte (j'ai épuré le code pour que j'y voir plus clair). Pour que ça fonctionne, il faut que tes Shapes Pays soient renommés comme les noms des villes, la carte de France = Paris, etc... :

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
 
Sub MatriceDeBulles()
 
    '-----Constantes
    Const Couleur As Long = 670343 'Couleur des bulles
    '-----Variables
    Dim Fe As Worksheet
    Dim Ech As Double, L As Double, T As Double, W As Double
    Dim c As Range, Plage As Range
    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
 
End Sub

Hervé.

[awa123]

Bonjour ,

Je cherche le code qui permet, à partir d'une feuille excel de rentrer les coordonnées des bulles (qui sont toujours proportionnelles entre elles) sur une même image et ainsi fixer le centre de chaque bulles.

cf. l'illustration en pièce jointe : sur la feuille 2, on rentre les valeurs et sur la feuille 1, on voit le resultat.


Je ne sais pas si c'est possible que l'on mette dans le code:

L = .Left + la valeur qu'on rentre en "C3"
T = .Top + la valeur qu'on rentre en "D3"

Ainsi, on jouant sur les valeurs en "C3" et "D3" on trouvera l'emplacement correspondant.

Merci beaucoup!!