[XL-2010] Créer forme (flèche) par une macro

Sub routes() Dim sh As Shape Dim route As String Dim nb As Double Dim i As Integer Dim cel As Range Application.ScreenUpdating = False Sheets("données").Select nb = Sheets("données").UsedRange.Rows.Count For Each cel In Range("C2:C" & nb) If Not IsEmpty(cel) Then route = cel.Value Sheets("plan").Select ' Alors créer une flèche reliant les deux points End If Next cel End Sub

Code:

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
Option Explicit
 
Sub Trace()
Dim D As String, A As String
 
'ici on peut boucler pour prendre en considération toutes les données
With Worksheets("Données")
    D = .Range("A2")
    A = .Range("B2")
End With
TraceRoute D, A
End Sub
 
Private Sub TraceRoute(ByVal Depart As String, ByVal Arrivee As String)
Dim ShpD As Shape, ShpA As Shape
 
With Worksheets("Plan")
    On Error Resume Next
    Set ShpD = .Shapes(Depart)
    Set ShpA = .Shapes(Arrivee)
    On Error GoTo 0
 
    If Not ShpD Is Nothing And Not ShpA Is Nothing Then
        With .Shapes.AddConnector(msoConnectorStraight, ShpD.Left, ShpD.Top, ShpA.Left, ShpA.Top)  'msoConnectorCurve'msoConnectorElbow
            With .Line
                .EndArrowheadStyle = msoArrowheadOpen
                .Weight = 2.25
                .ForeColor.RGB = RGB(192, 0, 0)
            End With
            With .ConnectorFormat
                .BeginConnect ShpD, 2
                .EndConnect ShpA, 6
            End With
        End With
    End If
    Set ShpD = Nothing
    Set ShpA = Nothing
End With
End Sub