Compliquer à réaliser : un fil d'ariane sous Excel

Option Explicit

Sub FilAriane()
Dim Nlignes&, xrg As Range, i&, j&, deb&, tail&

Application.ScreenUpdating = False
With Sheets("Feuil1")
  Nlignes = .Range(.Range("a1"), .Range("a" & .Rows.Count).End(xlUp)).Rows.Count
  .Range(.Range("d1"), .Range("d1").End(xlDown)).Clear
  With .Range("d1:d" & Nlignes)
    .Clear
    With .Font
      .Name = "Calibri"
      .FontStyle = "Normal"
      .Size = 11
    End With
  End With
      
  For j = 1 To Nlignes
    For i = 1 To Nlignes
      .Range("D" & j) = .Range("D" & j) & .Range("A" & i) & " è "
    Next i
      .Range("D" & j) = Left(.Range("D" & j), Len(.Range("D" & j)) - 3)
  Next j
  
  For j = 1 To Nlignes
    deb = 1
    tail = 0
    For i = 1 To Nlignes
      Select Case i
        Case 1 To j - 1
          tail = Len(.Range("A" & i))
          With .Range("D" & j).Characters(deb, tail).Font
            .Color = RGB(60, 140, 230)
          End With
          deb = deb + tail + 1: tail = 1
          With .Range("D" & j).Characters(deb, 1).Font
            .Name = "Wingdings"
            .Color = RGB(0, 0, 0)
          End With
          deb = deb + 2
        Case j
          tail = Len(.Range("A" & i))
          With .Range("D" & j).Characters(deb, tail).Font
            .Color = RGB(255, 0, 0)
            .Bold = True
          End With
          deb = deb + tail + 1: tail = 1
          With .Range("D" & j).Characters(deb, tail).Font
            .Name = "Wingdings"
            .Color = RGB(0, 0, 0)
          End With
          deb = deb + 2
        Case j + 1 To Nlignes
          tail = Len(.Range("A" & i))
          With .Range("D" & j).Characters(deb, tail).Font
            .Color = RGB(200, 200, 200)
          End With
          deb = deb + tail + 1: tail = 1
          If i <> Nlignes Then
            With .Range("D" & j).Characters(deb, tail).Font
              .Name = "Wingdings"
              .Color = RGB(0, 0, 0)
            End With
            deb = deb + 2
          End If
      End Select
    Next i
  Next j
End With
Application.ScreenUpdating = False
End Sub