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