organigramme excel

[newbie64]

Bonjour à toutes et à tous,

J'espère que mon mot vous trouve en bonne santé!

J'aurai besoin de votre appui. Je travaille sur une macro pour générer un organigramme via des données entrées dans un tableau Excel. Il fonctionne bien. Néanmoins, je souhaite le rendre plus facile d'utilisation pour mes collègues et rajouter une fonctionnalité.

Actuellement, il ne me propose que les liens hiérarchiques.

Ma demande est la suivant (Bouteille à la mer 😉 ) : auriez-vous une proposition à intégrer au code qui permettrait de rajouter les liens fonctionnels également ? Si pas possible avec ce code, je suis ouverte à changer la macro.

Sub Macro6()
Dim ogSALayout As SmartArtLayout
Dim QNode As SmartArtNode
Dim QNodes As SmartArtNodes
Dim t As Integer
Set ogSALayout = Application.SmartArtLayouts(92) 'reference to organization chart
Set ogShp = ActiveWorkbook.ActiveSheet.Shapes.AddSmartArt(ogSALayout)
Set QNodes = ogShp.SmartArt.AllNodes
t = QNodes.Count

While QNodes.Count = t
QNodes(QNodes.Count).Delete
Wend

While QNodes.Count < Range("B3").End(xlDown).Offset(-2, 0).Row
QNodes.Add.Promote
Wend


For i = 3 To Range("B3").End(xlDown).Row

While QNodes(Range("B" & i)).Level > Range("D" & i).Value
QNodes(Range("B" & i)).Promote
Wend

QNodes(Range("B" & i)).TextFrame2.TextRange.Text = Range("C" & i)
Next i

For i = 3 To Range("B3").End(xlDown).Row
While QNodes(Range("B" & i)).Level < Range("D" & i).Value
QNodes(Range("B" & i)).Demote
Wend

Next i

End Sub