Sub main()
Dim datas, pts, dict, k
Dim pl As Range, lig As Long, col As Long, ok As Boolean
Dim v As Double, coord As Long, memo(1 To 2)
Set dict = CreateObject("Scripting.Dictionary")
'recup points
Set pl = Cells.Find("Rectangles"): If pl Is Nothing Then Exit Sub
Set pl = pl.CurrentRegion
datas = pl.Offset(2, 1).Resize(pl.Rows.Count - 2, pl.Columns.Count - 1).Value
ReDim pts(1 To pl.Rows.Count * pl.Columns.Count / 2, 1 To 2)
For lig = 1 To UBound(datas)
For col = 1 To UBound(datas, 2) Step 2
dict(datas(lig, col) & ";" & datas(lig, col + 1)) = dict(datas(lig, col) & ";" & datas(lig, col + 1)) + 1
Next col
Next lig
' élaguer
For Each k In dict
If dict(k) Mod 2 = 0 Then dict.Remove k
Next k
' ordonner
ReDim pts(1 To dict.Count, 1 To 2)
pts(1, 1) = 0: pts(1, 2) = 0
dict.Remove "0;0"
For lig = 2 To dict.Count + 1
ok = False: memo(2) = 999999
coord = lig Mod 2
For Each k In dict
If CDbl(Split(k, ";")(coord)) = pts(lig - 1, coord + 1) Then
'même abcisse ou ordonnée selon si lig pair ou impair
v = Abs(CDbl(Split(k, ";")(Abs(coord - 1))) - pts(lig - 1, Abs(coord - 2)))
If v < memo(2) Then
' + petite distance
memo(1) = k: memo(2) = v: ok = True
End If
End If
Next k
' ajout point
If ok Then
pts(lig, 1) = CDbl(Split(memo(1), ";")(0)): pts(lig, 2) = CDbl(Split(memo(1), ";")(1))
dict.Remove memo(1)
Else
MsgBox "Anomalie dans la continuité des points, abandon": Exit Sub
End If
Next lig
Set dict = Nothing
' restitution
Range([R6:S6], [R6:S6].End(xlDown)).Offset(, 1).ClearContents
[S6:T6].Resize(UBound(pts)) = pts
End Sub