Autres Tableau de profil

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   If Not Intersect(Target, Range("b4:f23")) Is Nothing Then
      Cells(Target.Row, "b").Resize(, 5).ClearContents
      Target.Font.Name = "Wingdings"
      Target = Chr(108)
      Cancel = True
      Tracer
   End If
End Sub

Sub Tracer()
Dim xshp As Shape, derlig&, i&, k&
Dim debH, debV, finH, finV
   Application.ScreenUpdating = False
   With Sheets("Feuil1")
      For Each xshp In .Shapes
         If xshp.Name Like "Ma-Ligne*" Then xshp.Delete
      Next xshp
      derlig = .Cells(.Rows.Count, "a").End(xlUp).Row
      If derlig = 4 Then Exit Sub
      For i = 4 To derlig - 1
         For k = 2 To 6
            If .Cells(i, k) <> "" Then Exit For
         Next k
         If k <= 6 Then
            debH = .Cells(i, k).Left + .Cells(i, k).Width / 2
            debV = .Cells(i, k).Top + .Cells(i, k).Height / 2
            For k = 2 To 6
               If .Cells(i + 1, k) <> "" Then Exit For
            Next k
            If k <= 6 Then
               finH = .Cells(i + 1, k).Left + .Cells(i + 1, k).Width / 2
               finV = .Cells(i + 1, k).Top + .Cells(i + 1, k).Height / 2
               With .Shapes.AddConnector(msoConnectorStraight, debH, debV, finH, finV)
                  .Name = "Ma-Ligne" & i
                  .Line.Weight = 2.5
                  .Line.ForeColor.RGB = RGB(0, 0, 255)
               End With
            End If
         End If
      Next i
   End With
End Sub