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

[nak]

Bonjour à tous,

Je suis en train d'essayer de créer un fil d’Ariane sur Excel. Oui je sais, j'ai de drôles d'idées !
Il faut donc jouer avec les caractères d'une même cellule. J'ai tenté de commencer le code mais j'ai très vite bloqué car je n'arrive pas à compter les caractères de la chaine.

Est-ce que quelqu'un à une idée à suggérer ?
Je joins un exemple car mon résultat est assez difficile à expliquer.

Merci par avance.

A+

Sub FilAriane()

For l = 1 To 6
    For i = 1 To 6
        Sheets("Feuil1").Range("D" & l) = Sheets("Feuil1").Range("D" & l) & _
        Sheets("Feuil1").Range("A" & i) & " è "
    Next i
Next l

nbCarac = Len(Sheets("Feuil1").Range("D1")) - 10

With Sheets("Feuil1").Range("D1").Characters(Start:=nbCarac, Length:=3).Font
        .Name = "Arial"
        .FontStyle = "Normal"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 23
End With
    
End Sub

 

[mapomme]

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

Bonjour nak,

Un essai dans le fichier joint.

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

 

[nak]

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

Bonjour mapomme,

Alors là merci ! Trop bien joué la variable j avec les 3 cas de figure.
J'utilise vba pour excel depuis un bon moment mais je suis encore loin de sortir ce type de code.

C'est parfait, il n'y a rien à ajouter... MERCI BEAUCOUP.

A+