XL 2019 organigramme en VBA

[halecs93]

Bonjour à toutes et à tous,

J'ai tenté un code VBA afin de créer automatiquement un organigramme hiérarchique (utilisant SmartArt).

Je rencontre une erreur à l'instruction : QNodes(Range("B" & i)).Demote

Quelqu'un(e) aurait une idée pour me sortir de cette impasse ?

Merci beaucoup

 

[Staple1600]

Re

@patricktoulon
Pourquoi faire compliqué quand on peut faire simple?
Excel offre en natif un large choix d'organigramme
(personnalisable à souhait facilement par le ruban)
C'est d'ailleurs sur le SmartArt que le demandeur avait porté son choix (cf message#1)

Quel intérêt ne pas utiliser les nouvelles fonctionnalités offertes dans les nouvelles versions d'Excel ?

 

[halecs93]

Re

@halecs93
Même si le demandeur semble ignorer mes messages, je persiste
Le code VBA dans la PJ du message#1 fonctionne si on respecte ce que j'évoquais en message#10



Pour s'en convaincre
Lancer cette macro sur une feuille vierge

Sub creer_test()
[B3] = 1: [B3:B14].DataSeries
[C3:C14].FormulaR1C1 = "=""NOM ""&ROW()-2&"" Prénom""&ROW()-2"
[D3:D14] = Application.Transpose(Split("1u2u3u3u4u2u3u3u4u2u3u2", "u"))
End Sub

Puis lancer la macro de création de l'organigramme.
(je la remets ici par commodité)

Spoiler: macro initiale (identique dans PJ et vidéo YT

Sub orga()
Dim ogSALayout As SmartArtLayout, QNode As SmartArtNode, QNodes As SmartArtNodes, t%
     On Error GoTo Erreur
     Set ogSALayout = Application.SmartArtLayouts(92)
     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

     Exit Sub
Erreur: MsgBox "Une erreur est survenue"
End Sub

Résultat: J'obtiens un organigramme
Je n'ai donc pas de message d'erreur, ce qui était la question initiale, non ?
Et pour ce faire, j'ai simplement suivi le tuto (la vidéo) à la lettre

L'avantage de passer par SmartArt, c'est qu'on bénéficie ensuite des options de mise en forme offertes nativement par Excel.

(pas besoin de réinventer la roue, n'est-ce pas @patricktoulon )

Le demandeur est là...et il n'ignore aucun message Je regarde, une à une les propositions. Mais en tout cas, grand merci

 

[patricktoulon]

re
Bonjour @Staple1600
ben par ce que je sais les faire avec des sHapes et que je connais pas du tout les smartarts

 

[Staple1600]

Re


@halecs93
Content de le savoir
Mais comme je n'ai pas lu de ta part si tu avais encore ou pas le message d'erreur, je pensais que tu avais zappé mes messages.
Tu as fait le test proposé dans le message#14 ?

Test OK chez moi, sans message d'erreur
(Excel 365 + W10)

@patricktoulon
Moi, non plus je ne connais pas plus que cela les SmartArt
Simplement, comme disait Jean-Claude Convenant, j'essaie d'utiliser les fonctions natives d'Excel autant que faire se peut
Et je conseille (quand la fièvre du principe KISS me reprend) aux primo-utilisateurs d'Excel de faire de même

 

[Usine à gaz]

Re à tous
On a aussi ce fichier de notre cher disparu :

Formation Excel VBA JB

 

[halecs93]

Re

@halecs93
Même si le demandeur semble ignorer mes messages, je persiste
Le code VBA dans la PJ du message#1 fonctionne si on respecte ce que j'évoquais en message#10



Pour s'en convaincre
Lancer cette macro sur une feuille vierge

Sub creer_test()
[B3] = 1: [B3:B14].DataSeries
[C3:C14].FormulaR1C1 = "=""NOM ""&ROW()-2&"" Prénom""&ROW()-2"
[D3:D14] = Application.Transpose(Split("1u2u3u3u4u2u3u3u4u2u3u2", "u"))
End Sub

Puis lancer la macro de création de l'organigramme.
(je la remets ici par commodité)

Spoiler: macro initiale (identique dans PJ et vidéo YT

Sub orga()
Dim ogSALayout As SmartArtLayout, QNode As SmartArtNode, QNodes As SmartArtNodes, t%
     On Error GoTo Erreur
     Set ogSALayout = Application.SmartArtLayouts(92)
     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

     Exit Sub
Erreur: MsgBox "Une erreur est survenue"
End Sub

Résultat: J'obtiens un organigramme
Je n'ai donc pas de message d'erreur, ce qui était la question initiale, non ?
Et pour ce faire, j'ai simplement suivi le tuto (la vidéo) à la lettre

L'avantage de passer par SmartArt, c'est qu'on bénéficie ensuite des options de mise en forme offertes nativement par Excel.

(pas besoin de réinventer la roue, n'est-ce pas @patricktoulon )

En effet, cela fonctionne. Souci... l'organigramme créé est horizontal (et illisible) alors que je souhaiterais l'obtenir en vertical. Et question subsidiaire, la taille des smatsarts peut-elle être adaptée au contenu ?

Merci

 

[halecs93]

Re à tous
On a aussi ce fichier de notre cher disparu :

Formation Excel VBA JB

Merci. C'est aussi une autre approche.

 

[Staple1600]

Bonjour

@halecs93
Pour ma part dans un premier temps, je me suis borné à résoudre la question du message#1
A savoir: faire disparaitre le message d'erreur.
C'est désormais chose faite

En investiguant un peu plus, tu peux déjà faire des tests en te basant sur les valeurs suivantes.
(En remplaçant 92 par une des valeurs suivantes dans cette ligne de code)
Set ogSALayout = Application.SmartArtLayouts(92)

 

[Staple1600]

Re

@halecs93
Voila ce que j'obtiens en prenant la valeur 88
C'est la disposition que tu souhaites ?

 

[halecs93]

Re

@halecs93
Voila ce que j'obtiens en prenant la valeur 88
C'est la disposition que tu souhaites ?
Regarde la pièce jointe 1172775

Oui, je testais aussi de mon côté des codes. Pas facile de trouver les bons, Mais c'est Ok. GRand merci.

 

[Staple1600]

Re

@halecs93
Si tu veux mettre en forme l'organigramme une fois qu'il est généré, tu peux tester cette macro

Sub Mise_en_forme_ORGA()
Dim shp As Shape
Application.ScreenUpdating = False
With ActiveSheet
    With .Shapes(1)
        .Height = 500: .Width = 1200: .Top = 7: .Left = 13
    End With
    For Each shp In .Shapes
    shp.SmartArt.Color = Application.SmartArtColors(8) 'valeurs possibles: 1 à 38
    shp.SmartArt.QuickStyle = Application.SmartArtQuickStyles(8) ''valeurs possibles: 1 à 14
    Next
End With
End Sub

 

[halecs93]

Re

@halecs93
Si tu veux mettre en forme l'organigramme une fois qu'il est généré, tu peux tester cette macro

Sub Mise_en_forme_ORGA()
Dim shp As Shape
Application.ScreenUpdating = False
With ActiveSheet
    With .Shapes(1)
        .Height = 500: .Width = 1200: .Top = 7: .Left = 13
    End With
    For Each shp In .Shapes
    shp.SmartArt.Color = Application.SmartArtColors(8) 'valeurs possibles: 1 à 38
    shp.SmartArt.QuickStyle = Application.SmartArtQuickStyles(8) ''valeurs possibles: 1 à 14
    Next
End With
End Sub

Ha merci... je vais regarder cela