Construction réseau (différents chemins possibles)

Sub Macro2()
With Sheets("Feuil1")
    For i = .Cells.Find("*", , , , xlByRows, xlPrevious).Row - 1 To 2 Step -1
        If .Cells(i, "B").Value <> .Cells(i + 1, "B") Then Rows(i + 1).Insert Shift:=xlDown
    Next i
End With
End Sub

Option Explicit
Dim Tableau(), Premier$, Point$, Ligne%, d As Object

Sub Choix_Tableaux()
Dim f As Worksheet, i&, l&

'Désactivation des applications.
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
End With

On Error GoTo Fin

    Set f = Sheets("Test_4")
    With f
        l = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
        .Range(.Cells(2, "E"), .Cells(l, "E")).Clear
        For i = 2 To l
            If .Cells(i, "D").Value <> "" Then
                Création_Chemin f.Name, .Cells(i, "D").CurrentRegion, .Cells(i, "D"), .Cells(i, "D").CurrentRegion.Row
            End If
        Next i
        .Columns(5).AutoFit
    End With

'Désactivation des applications.
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
End With
Exit Sub

Fin:
    MsgBox "Une erreur s'est produite ligne" & i, 16
    'Désactivation des applications.
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
    Exit Sub
End Sub

Sub Création_Chemin(Feuille$, Temp As Range, Pre As Range, ii&)
Dim i%, j%
Set d = CreateObject("Scripting.Dictionary")
With Sheets(Feuille)
    Premier = Pre.Value
    Tableau = Temp.Resize(, 5).Value
    'Permet de ne pas perdre de temps avec des réseaux d'une ligne
    If UBound(Tableau) = 1 Then .Cells(ii, "E").Value = "Faux": Exit Sub
    'On vérifie qu'il y a bien une valeur dans toutes les colonnes
    For i = LBound(Tableau) To UBound(Tableau)
        For j = 1 To 3
            If Tableau(i, j) = "" Then
                .Cells(ii, "E").Value = "Manque des informations"
                .Cells(ii, "A").CurrentRegion.Interior.Color = 65535
                Exit Sub
            End If
        Next j, i
    Ecriture_Précédent Pre.Value, Pre.Offset(, -3).Value, 0
    For i = 1 To UBound(Tableau)
        If d.exists(Tableau(i, 2)) Then
            d.Remove (Tableau(i, 2))
            Tableau(i, 5) = "Faux"
        End If
    Next i
    With .Cells(ii, "E").Resize(UBound(Tableau))
        .NumberFormat = "@"
        .Value = Application.Index(Tableau, Evaluate("Row(" & LBound(Tableau) & ":" & UBound(Tableau) & ")"), 5)
    End With
End With
End Sub

Sub Ecriture_Précédent(Précédent, Point, Ligne)
Dim i%, a
For i = 1 To UBound(Tableau)
    If Tableau(i, 2) = Précédent And Tableau(i, 3) <> Premier And Ligne <> i Then a = Tableau(i, 2): Tableau(i, 2) = Tableau(i, 3): Tableau(i, 3) = a
    If Tableau(i, 3) = Précédent Then
        d(Tableau(i, 3)) = ""
        If Ligne = 0 Then
            Tableau(i, 5) = Point
            Else
            Tableau(i, 5) = Tableau(Ligne, 5) & "-" & Tableau(i, 1)
        End If
        Ecriture_Précédent Tableau(i, 2), Tableau(i, 5), i
    End If
Next i
End Sub