tracer connecteur entre 2 cellules

Dim P1 As Range, P2 As Range, c As Range 'mémorise les variables

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Set P1 = [A6:A25]: Set P2 = [E3:E28] 'plages à adapter
Cancel = True
If Not Intersect(Target, P1) Is Nothing Then
  Set c = Target
  P1.Borders.LineStyle = xlNone
  c.Borders.Weight = xlThick
ElseIf Not c Is Nothing And Not Intersect(Target, P2) Is Nothing Then
  Target.Interior.Color = c.Interior.Color
  Me.Shapes.AddLine c.Left + c.Width, c.Top + c.Height / 2, Target.Left, Target.Top + Target.Height / 2
  Me.DrawingObjects.ShapeRange.Line.ForeColor.SchemeColor = 12 'couleur bleue
End If
End Sub

Sub EffaceConnecteurs() 'se lance par Ctrl+E
If P1 Is Nothing Then Exit Sub
Me.DrawingObjects.Delete
P1.Borders.LineStyle = xlNone
P2.Interior.ColorIndex = xlNone
Set c = Nothing
End Sub

Dim cel As Range, couleur& 'mémorise les variables

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, colPasse$, colPoints$
Set r = [J4:J10] 'plage à adapter
colPasse = "E" 'à adapter
colPoints = "H" 'à adapter
DrawingObjects.Delete 'RAZ
On Error Resume Next 'si la cellule ne peut être touvée
For Each r In r
  If r <> "" Then
    Set cel = Nothing 'réinitialise
    couleur = r.Interior.Color
    MaSelection r.MergeArea 'car cellule fusionnée
    MaSelection Columns(colPoints).Find(r(1, 3), , xlValues, xlWhole)
    MaSelection Columns(colPasse).Find(r(1, 2))
  End If
Next
End Sub

Sub MaSelection(Target As Range)
If Not cel Is Nothing Then _
  Shapes.AddLine(cel.Left, cel.Top + cel.Height / 2, Target.Left + Target.Width, Target.Top + Target.Height / 2) _
    .Line.ForeColor.RGB = couleur
Set cel = Target
End Sub

MaSelection r.MergeArea 'car cellule fusionnée