XL 2019 organigramme en VBA

halecs93

halecs93

XLDnaute Impliqué
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
 

Pièces jointes

  • ORGANIGRAMME 3.xlsm
    21.6 KB · Affichages: 12
Solution
Staple1600
Re

@halecs93
Voila ce que j'obtiens en prenant la valeur 88
C'est la disposition que tu souhaites ?
Orga2Capture.PNG
Trier par date Trier par votes
Staple1600

Staple1600

XLDnaute Barbatruc
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)
Orga2Capture.PNG

Quel intérêt ne pas utiliser les nouvelles fonctionnalités offertes dans les nouvelles versions d'Excel ?
 
Vote positif 0 Vote négatif
halecs93

halecs93

XLDnaute Impliqué
Staple1600 à dit:
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
VB: 
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é)
VB: 
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 ;))
Cliquez pour agrandir...
Le demandeur est là...et il n'ignore aucun message ;) Je regarde, une à une les propositions. Mais en tout cas, grand merci :)
 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
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 ;)
 
Vote positif 0 Vote négatif
halecs93

halecs93

XLDnaute Impliqué
Staple1600 à dit:
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
VB: 
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é)
VB: 
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 ;))
Cliquez pour agrandir...
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

1687066190925.png
 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
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)
OrgaCapture.PNG
 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Re

@halecs93
Si tu veux mettre en forme l'organigramme une fois qu'il est généré, tu peux tester cette macro
VB: 
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
 
Vote positif 0 Vote négatif
halecs93

halecs93

XLDnaute Impliqué
Staple1600 à dit:
Re

@halecs93
Si tu veux mettre en forme l'organigramme une fois qu'il est généré, tu peux tester cette macro
VB: 
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
Cliquez pour agrandir...
Ha merci... je vais regarder cela :)
 
Vote positif 0 Vote négatif

Discussions similaires

halecs93
  • Question
XL 2016 organigramme en VBA
Réponses
1
Affichages
606
vgendron
vgendron
N
  • Question
organigramme excel
Réponses
0
Affichages
597
newbie64
N
E
  • Question
Microsoft 365 Organigramme de groupe de sociétés avec pourcentage affichés sur les lignes inter-sociétés
Réponses
2
Affichages
1 K
Eldict4teur
E
Saalut
  • Question
XL 2019 J’ai tenté de filtrer les anomalies dans le tableau en utilisant un code VBA. Malheureusement, le code initial ne semble pas fonctionner correctement.
Réponses
2
Affichages
211
Saalut
Saalut
halecs93
  • Question
XL 2016 Calculatrice Vba
Réponses
8
Affichages
506
halecs93
halecs93
C
  • Question
Microsoft 365 VBA activer filtre élaboré suite changement donnée d'une cellule
Réponses
5
Affichages
215
Chounoé
C
M
  • Question
XL 2019 étirer liste déroulante
Réponses
10
Affichages
406
milckush
M
E
  • Résolu(e)
Microsoft 365 power query recup en tete dans colonne personnalisee
Réponses
4
Affichages
311
eric72
E
G
  • Question
XL 2016 VBA - Gestion de l'affichage et des rafraîchissement avec l'instruction Freezepanes = false
Réponses
4
Affichages
374
Greedyyy3317
G
Bernard38
  • Résolu(e)
Microsoft 365 VBA : formule Excel en variable
2
Réponses
24
Affichages
1 K
mapomme
mapomme

Membres actuellement en ligne

11 membres et 189 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 629
Messages
2 111 349
Membres
111 110
dernier inscrit
chergui