Option Explicit
Sub Scan()
Dim Zone As Range, Cellule As Range
Dim ValOk As String
Dim Ligne As Integer, Colonne As Integer
Application.ScreenUpdating = False
Set Zone = Feuil1.Range("G1:DZ154")
ValOk = ";"
Call EffacerConnecteur(Zone.Parent)
For Colonne = 1 To Zone.Columns.Count - 1
For Ligne = 1 To Zone.Rows.Count - 1
Zone.Cells(Ligne, Colonne).Select
If Zone.Cells(Ligne, Colonne).Value <> "" Then
If InStr(1, ValOk, ";" & Zone.Cells(Ligne, Colonne).Value & ";") = 0 Then
Call Tracer(Zone.Offset(, Colonne - 1).Resize(, Zone.Columns.Count - Colonne + 1), Zone.Cells(Ligne, Colonne).Value)
ValOk = ValOk & Zone.Cells(Ligne, Colonne).Value & ";"
End If
End If
Next
Next
Application.ScreenUpdating = True
End Sub
Sub Tracer(ZoneTravail As Range, Valeur As String)
Dim Rech As Range
Dim Origine As String, Dernier As String
Dim Connecteur As Shape
Dim Feuille As Worksheet
Dim CptValeur As Integer
Set Feuille = ZoneTravail.Parent
Set Rech = ZoneTravail.Find(what:=Valeur, after:=ZoneTravail.SpecialCells(xlCellTypeLastCell), LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlNext)
If Not Rech Is Nothing Then
Origine = Rech.Address
Dernier = Rech.Address
Do
If Dernier <> Rech.Address Then
CptValeur = CptValeur + 1
Set Connecteur = Feuille.Shapes.AddConnector(msoConnectorStraight, Feuille.Range(Dernier).Left + Rech.Width, Feuille.Range(Dernier).Top + Rech.Height / 2, Rech.Left - Feuille.Range(Dernier).Left - Rech.Width, Rech.Top - Feuille.Range(Dernier).Top)
Connecteur.Name = "Auto_Trace_" & Valeur & "_" & CptValeur
Connecteur.Line.ForeColor.SchemeColor = 16
End If
Dernier = Rech.Address
Set Rech = ZoneTravail.FindNext(Rech)
Loop While Not Rech Is Nothing And Rech.Address <> Origine
End If
End Sub
Sub EffacerConnecteur(Feuille As Worksheet)
Dim Connecteur As Shape
For Each Connecteur In Feuille.Shapes
If LCase(Left(Connecteur.Name, 11)) = "auto_trace_" Then
Connecteur.Delete
End If
Next
End Sub