Sub ajustementOrganigramme() Dim modèleSALayout As SmartArtLayout Dim noeudQ As SmartArtNode Dim forme As Shape Dim ensembleNoeudsQ As SmartArtNodes Dim t As Integer Set modèleSALayout = Application.SmartArtLayouts(91) Set forme = ActiveWorkbook.ActiveSheet.Shapes.AddSmartArt(modèleSALayout) Set ensembleNoeudsQ = forme.smartArt.AllNodes t = ensembleNoeudsQ.Count ' Supprimer les nœuds en surplus While ensembleNoeudsQ.Count = t ensembleNoeudsQ(ensembleNoeudsQ.Count).Delete Wend ' Ajouter des nœuds jusqu'à ce que le nombre soit égal au nombre de lignes - 2 While ensembleNoeudsQ.Count < Range("B3").End(xlDown).Offset(-2, 0).Row ensembleNoeudsQ.Add.Promote Wend ' Remplir les nœuds avec des données et des images For i = 3 To Range("B3").End(xlDown).Row ' Ajuster la hiérarchie des nœuds While ensembleNoeudsQ(Range("B" & i)).Level > Range("D" & i).Value ensembleNoeudsQ(Range("B" & i)).Promote Wend ' Ajouter une image à la forme With ensembleNoeudsQ(Range("B" & i)).Shapes.Item(2).Fill .Visible = msoTrue .UserPicture "C:\Users\space\Desktop\Excel videos\Organigramme" & "\" & Range("E" & i) .TextureTile = msoFalse End With ' Ajouter du texte au nœud ensembleNoeudsQ(Range("B" & i)).TextFrame2.TextRange.Text = Range("C" & i) Next i ' Ajuster la hiérarchie des nœuds restants For i = 3 To Range("B3").End(xlDown).Row While ensembleNoeudsQ(Range("B" & i)).Level < Range("D" & i).Value ensembleNoeudsQ(Range("B" & i)).Demote Wend Next i Exit Sub End Sub
Пікірлер: 2