Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2019 organigramme en VBA

Créer une discussion
  • Initiateur de la discussion Initiateur de la discussion halecs93
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire

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

Trier par date Trier par votes
bonsoir
je pense qu'il y a déja une erreur dans ton organisation du tableau
en effet tu a 3 etage 1 , 2 et 3

a)
sauf que les 3emeetage on ne sait pas du quel 2d étage, ils sont les enfants

b)
et si on devait considérer le tableau dans l'ordre alors il manque le 2 du premier
donc dans n'importe quel cas ,ton problème en l’état reste insolvable
 
Vote positif 0 Vote négatif
Bonjour et merci pour votre réponse.

En effet, le tableau est à considérer dans l'ordre. Le fait est que les premiers "3" n'ont pas de "2" comme père mais qu'ils sont au même niveau de strate hiérarchique que les autres "3" (qui eux dépendent d'un "2")
 
Vote positif 0 Vote négatif
En "inventant" un numéro "2" (en D4), l'organigramme se génère. Mais je n'arrive pas à définir par défaut celui que je souhaite réellement. Sur l'illustration, apparaît en haut l'affichage par défaut et en bas l'affichage souhaité... une solution ?

Quoi qu'il en soit, un grand merci.
 

Pièces jointes

Vote positif 0 Vote négatif
re
pour commencer je te suggère d'ajouter une colonne supplémentaire a ton tableau désignant le parent
comme ça même si il est dans le désordre on s'y retrouve

apres pour être honnête je decouvre ce truc en même temps que toi mes organigrames je les fait avec des shapes toutes simples

en rentrant plus tard dans l'après midi si j'ai un peu de temps je te ferais un exemple
😉
 
Vote positif 0 Vote négatif
re
le voila avec les connecteurs j'ai fait au plus proche de ton exemple
et en plus ils sont cliquables et les connecteurs sont en couleur
VB: 
Sub ORGANIGRAME2()
    deleteshape
    Dim L1&, L2&, L#, T, C1, C2, i, ecart&, haut&, shapeparent, pere, shap
    T = 20
    L1 = 500
    ecart = 17
    larg = 30
    haut = 15

    For Each shap In ActiveSheet.Shapes: shap.Delete: Next

    Set r = Range("B3:E" & Cells(Rows.Count, 2).End(xlUp).Row)
    'le père
    Set pere = ActiveSheet.Shapes.AddShape(msoShapeRectangle, L1, T, larg, haut)
    pere.Name = r.Cells(1, 2)
    pere.TextFrame.Characters.Text = r.Cells(1, 2)
    pere.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    pere.TextFrame2.VerticalAnchor = msoAnchorMiddle
    ActiveSheet.DrawingObjects(pere.Name).Font.Size = 9
    pere.OnAction = "actionshape"

    'les enfant etage(2)
    L2 = L1 - ((WorksheetFunction.CountIf(r.Columns(3), "2") * (ecart)) / 2) - larg - ecart   'position left du premier enfant etage(2)
    For i = 2 To r.Rows.Count
        If r.Cells(i, 3) = 2 Then
            T = 20 * 2 + 3
            Set shap = ActiveSheet.Shapes.AddShape(msoShapeRectangle, L2, T, larg, haut)
            shap.Name = r.Cells(i, 2)
            shap.TextFrame.Characters.Text = r.Cells(i, 2)
            shap.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
            shap.TextFrame2.VerticalAnchor = msoAnchorMiddle
            ActiveSheet.DrawingObjects(shap.Name).Font.Size = 8
            shap.OnAction = "actionshape"
            L2 = L2 + larg + ecart
            Set connecteur = ActiveSheet.Shapes.AddConnector(msoConnectorElbow, 100, 100, 100, 100)
            connecteur.Name = "ba" & shap.Name
            If shap.Left < pere.Left Then C1 = 3: C2 = 1 Else C1 = 3: C2 = 1
            connecteur.ConnectorFormat.BeginConnect pere, C1
            connecteur.ConnectorFormat.EndConnect shap, C2
            connecteur.Line.ForeColor.RGB = vbRed
        End If
    Next


    'les arrières enfant etage(3)
    For i = 1 To r.Rows.Count
        If r.Cells(i, 3) = 2 Then
            Set shapeparent = ActiveSheet.Shapes(r.Cells(i, 2))
            T = shapeparent.Top
            L = shapeparent.Left
        End If
        If r.Cells(i, 3) = 3 Then
            T = T + 25
            Set shap = ActiveSheet.Shapes.AddShape(msoShapeRectangle, L, T, larg, haut)
            shap.Name = r.Cells(i, 2)
            shap.TextFrame.Characters.Text = r.Cells(i, 2)
            shap.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
            shap.TextFrame2.VerticalAnchor = msoAnchorMiddle
            ActiveSheet.DrawingObjects(shap.Name).Font.Size = 8
            shap.Left = L + 5
            shap.OnAction = "actionshape"
            Set connecteur = ActiveSheet.Shapes.AddConnector(msoConnectorElbow, 100, 100, 100, 100)
            connecteur.Name = "boo" & shap.Name
            If shap.Left < shapeparent.Left Then C1 = 2: C2 = 2 Else C1 = 4: C2 = 4
            connecteur.ConnectorFormat.BeginConnect shapeparent, C1
            connecteur.ConnectorFormat.EndConnect shap, C2
            connecteur.Width = connecteur.Width - 2
            connecteur.Top = shapeparent.Top + haut
         connecteur.Line.ForeColor.RGB = vbGreen
    End If
    Next
End Sub

Sub actionshape()
    MsgBox Application.Caller
End Sub
Sub deleteshape()
Dim shap
For Each shap In ActiveSheet.Shapes: shap.Delete: Next
End Sub

demo
 
Vote positif 0 Vote négatif
Un grand merci pour cette proposition.... un détail, lorsque l'organigramme est créé, les shapes semblent limitées en taille...ce qui fait qu'on ne lit pas l'intégralité de son contenu
 
Vote positif 0 Vote négatif
re
ben c'est moi QUI limite en taille bien !?
sur sinon le visuel ne va pas être conforme a ce que tu a demandé
si tu veux plus large il te faut changer les valeur des variables (ce que j'avais prévu d'ailleurs)
et pour le coup je te fait ça automatique
VB: 
Option Explicit

Sub ORGANIGRAME2()
    deleteshape
    Dim L1&, L2&, L&, T, C1, C2, i, ecart&, haut&, shapeparent
    Dim pere, shap, lenX&, larg, r As Range, Cel As Range, connecteur
    T = 20
    L1 = 650
    larg = 40
    ecart = 20
    haut = 15

  deleteshape
    
    Set r = Range("B3:E" & Cells(Rows.Count, 2).End(xlUp).Row)
    
    'LA TAILLE de texte LA PLUS GRANDE
    For Each Cel In r.Columns(2).Cells
    If Cel <> "" Then If lenX < (Len(Cel.Value) * 8) Then lenX = Len(Cel.Value) * 8
    Next
    If lenX > larg Then larg = lenX:
     'le père
    Set pere = ActiveSheet.Shapes.AddShape(msoShapeRectangle, L1, T, larg, haut)
    pere.Name = r.Cells(1, 2)
    pere.TextFrame.Characters.Text = r.Cells(1, 2)
    pere.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    pere.TextFrame2.VerticalAnchor = msoAnchorMiddle
    ActiveSheet.DrawingObjects(pere.Name).Font.Size = 9
    pere.OnAction = "actionshape"

    'les enfant etage(2)
    'L2 = L1 - ((WorksheetFunction.CountIf(r.Columns(3), "2") * (ecart)) / 2) - larg - ecart   'position left du premier enfant etage(2)
     L2 = L1 - ((WorksheetFunction.CountIf(r.Columns(3), "2") * larg) / 2)  'position left du premier enfant etage(2)
  
    
    For i = 2 To r.Rows.Count
        If r.Cells(i, 3) = 2 Then
            T = 20 * 2 + 3
            Set shap = ActiveSheet.Shapes.AddShape(msoShapeRectangle, L2, T, larg, haut)
            shap.Name = r.Cells(i, 2)
            shap.TextFrame.Characters.Text = r.Cells(i, 2)
            shap.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
            shap.TextFrame2.VerticalAnchor = msoAnchorMiddle
            ActiveSheet.DrawingObjects(shap.Name).Font.Size = 9
            shap.OnAction = "actionshape"
            L2 = L2 + larg + ecart
            Set connecteur = ActiveSheet.Shapes.AddConnector(msoConnectorElbow, 100, 100, 100, 100)
            connecteur.Name = "ba" & shap.Name
            If shap.Left < pere.Left Then C1 = 3: C2 = 1 Else C1 = 3: C2 = 1
            connecteur.ConnectorFormat.BeginConnect pere, C1
            connecteur.ConnectorFormat.EndConnect shap, C2
            connecteur.Line.ForeColor.RGB = vbRed
        End If
    Next


    'les arrières enfant etage(3)
    For i = 1 To r.Rows.Count
        If r.Cells(i, 3) = 2 Then
            Set shapeparent = ActiveSheet.Shapes(r.Cells(i, 2))
            T = shapeparent.Top
            L = shapeparent.Left
        End If
        If r.Cells(i, 3) = 3 Then
            T = T + 25
            Set shap = ActiveSheet.Shapes.AddShape(msoShapeRectangle, L, T, larg, haut)
            shap.Name = r.Cells(i, 2)
            shap.TextFrame.Characters.Text = r.Cells(i, 2)
            shap.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
            shap.TextFrame2.VerticalAnchor = msoAnchorMiddle
            ActiveSheet.DrawingObjects(shap.Name).Font.Size = 9
            shap.Left = L + 5
            shap.OnAction = "actionshape"
            Set connecteur = ActiveSheet.Shapes.AddConnector(msoConnectorElbow, 100, 100, 100, 100)
            connecteur.Name = "boo" & shap.Name
            If shap.Left < shapeparent.Left Then C1 = 2: C2 = 2 Else C1 = 4: C2 = 4
            connecteur.ConnectorFormat.BeginConnect shapeparent, C1
            connecteur.ConnectorFormat.EndConnect shap, C2
            connecteur.Width = connecteur.Width - 2
            connecteur.Top = shapeparent.Top + haut
         connecteur.Line.ForeColor.RGB = vbGreen
    End If
    Next
End Sub

Sub actionshape()
    MsgBox Application.Caller
End Sub
Sub deleteshape()
Dim shap
For Each shap In ActiveSheet.Shapes: shap.Delete: Next
End Sub

demo

 
Vote positif 0 Vote négatif
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
halecs93 à dit:
Je rencontre une erreur à l'instruction : QNodes(Range("B" & i)).Demote
Cliquez pour agrandir...


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 😉)
 
Dernière édition:
Vote positif 0 Vote négatif
re
et puis soyons fous mettons y un peu de couleur


Code: 
 Option Explicit

Sub ORGANIGRAME2()
    deleteshape
    Dim L1&, L2&, L&, T, C1, C2, i, ecart&, haut&, shapeparent
    Dim pere, shap, lenX&, larg, r As Range, Cel As Range, connecteur
    T = 20
    L1 = 650
    larg = 40
    ecart = 20
    haut = 15

  deleteshape
    
    Set r = Range("B3:E" & Cells(Rows.Count, 2).End(xlUp).Row)
    
    'LA TAILLE de texte LA PLUS GRANDE
    For Each Cel In r.Columns(2).Cells
    If Cel <> "" Then If lenX < (Len(Cel.Value) * 8) Then lenX = Len(Cel.Value) * 8
    Next
    If lenX > larg Then larg = lenX:
     'le père
    Set pere = ActiveSheet.Shapes.AddShape(msoShapeRectangle, L1, T, larg, haut)
    pere.Name = r.Cells(1, 2)
    pere.TextFrame.Characters.Text = r.Cells(1, 2)
    pere.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    pere.TextFrame2.VerticalAnchor = msoAnchorMiddle
     pere.Fill.ForeColor.RGB = RGB(255, 0, 0)
           ActiveSheet.DrawingObjects(pere.Name).Font.Size = 9
    pere.OnAction = "actionshape"

    'les enfant etage(2)
    'L2 = L1 - ((WorksheetFunction.CountIf(r.Columns(3), "2") * (ecart)) / 2) - larg - ecart   'position left du premier enfant etage(2)
     L2 = L1 - ((WorksheetFunction.CountIf(r.Columns(3), "2") * larg) / 2)  'position left du premier enfant etage(2)
  
    
    For i = 2 To r.Rows.Count
        If r.Cells(i, 3) = 2 Then
            T = 20 * 2 + 3
            Set shap = ActiveSheet.Shapes.AddShape(msoShapeRectangle, L2, T, larg, haut)
            shap.Name = r.Cells(i, 2)
            shap.TextFrame.Characters.Text = r.Cells(i, 2)
            shap.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
            shap.TextFrame2.VerticalAnchor = msoAnchorMiddle
            ActiveSheet.DrawingObjects(shap.Name).Font.Size = 9
             ActiveSheet.DrawingObjects(shap.Name).Font.Color = vbBlue
             shap.OnAction = "actionshape"
            shap.Fill.ForeColor.RGB = vbGreen
            L2 = L2 + larg + ecart
            Set connecteur = ActiveSheet.Shapes.AddConnector(msoConnectorElbow, 100, 100, 100, 100)
            connecteur.Name = "ba" & shap.Name
            If shap.Left < pere.Left Then C1 = 3: C2 = 1 Else C1 = 3: C2 = 1
            connecteur.ConnectorFormat.BeginConnect pere, C1
            connecteur.ConnectorFormat.EndConnect shap, C2
            connecteur.Line.ForeColor.RGB = vbRed
        connecteur.Line.Weight = 2
        End If
    Next


    'les arrières enfant etage(3)
    For i = 1 To r.Rows.Count
        If r.Cells(i, 3) = 2 Then
            Set shapeparent = ActiveSheet.Shapes(r.Cells(i, 2))
            T = shapeparent.Top
            L = shapeparent.Left
        End If
        If r.Cells(i, 3) = 3 Then
            T = T + 25
            Set shap = ActiveSheet.Shapes.AddShape(msoShapeRectangle, L, T, larg, haut)
            shap.Name = r.Cells(i, 2).Text
            shap.TextFrame.Characters.Text = r.Cells(i, 2).Text
            shap.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
            shap.TextFrame2.VerticalAnchor = msoAnchorMiddle
            shap.Fill.ForeColor.RGB = RGB(200, 150, 0)
            ActiveSheet.DrawingObjects(shap.Name).Font.Color = vbRed
            ActiveSheet.DrawingObjects(shap.Name).Font.Size = 9
              shap.Left = L + 5
            shap.OnAction = "actionshape"
            Set connecteur = ActiveSheet.Shapes.AddConnector(msoConnectorElbow, 100, 100, 100, 100)
            connecteur.Name = "boo" & shap.Name
            If shap.Left < shapeparent.Left Then C1 = 2: C2 = 2 Else C1 = 4: C2 = 4
            connecteur.ConnectorFormat.BeginConnect shapeparent, C1
            connecteur.ConnectorFormat.EndConnect shap, C2
            connecteur.Width = connecteur.Width - 2
            connecteur.Top = shapeparent.Top + haut
         connecteur.Line.ForeColor.RGB = vbGreen
    connecteur.Line.Weight = 3
    End If
    Next
End Sub

Sub actionshape()
    MsgBox Application.Caller
End Sub
Sub deleteshape()
Dim shap
For Each shap In ActiveSheet.Shapes: shap.Delete: Next
End Sub
🥳
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

  • Question Question
XL 2016 organigramme en VBA
Réponses
1
Affichages
721
vgendron
N
  • Question Question
organigramme excel
Réponses
0
Affichages
784
newbie64
N
Y
  • Résolu(e)
XL 2013 Chronologie
Réponses
4
Affichages
136
Yvan1
Y
M
  • Résolu(e)
Microsoft 365 Trouver une valeur dans une colonne
Réponses
7
Affichages
226
mikeduff
M
  • Question Question
Autres Problème de Progress Bar (erreur d'ocx)
Réponses
0
Affichages
88
DenisHen
A
  • Question Question
Microsoft 365 Tri sur feuille protégée +Aide protection de données déjà saisies
Réponses
2
Affichages
298
TooFatBoy
  • Question Question
XL 2021 EXTRAIRE + SOMME des 6 meilleures valeurs avec condition par participant
Réponses
11
Affichages
349
Poulet13
T
  • Résolu(e)
XL 2019 Formulaire Congés VBA
Réponses
3
Affichages
152
cathodique
P
  • Résolu(e)
Microsoft 365 Validation des données avec VBA
2
Réponses
16
Affichages
336
pat66
P
E
  • Question 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
G
  • Résolu(e)
XL 2021 Transformer une formule en vba
2
Réponses
20
Affichages
750
kiki29
A
  • Question Question
Déplacer données en vba
Réponses
3
Affichages
469
akm
A
  • Résolu(e)
XL 2019 Problème de copie de plages non contiguës vers une autre feuille en VBA
Réponses
9
Affichages
289
flc13090
O
  • Question Question
XL 2019 Mise a jour prix en fonction de la date
Réponses
8
Affichages
396
Ocbpatate
O
A
  • Question Question
XL 2021 Fichier Excel VBA mis en quarantaine par l'antivirus
2
Réponses
19
Affichages
874
fanch55
  • Résolu(e)
Microsoft 365 Comment supprimer un espace entre deux chiffres ?
2
Réponses
18
Affichages
543
Staple1600
I
  • Résolu(e)
XL 2021 msgbox : timer vbyes
2 3
Réponses
40
Affichages
1 K
isandre
I
  • Question 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
363
Saalut
C
  • Résolu(e)
XL 2016 Ajustement automatique de la largeur d'une colonne
Réponses
5
Affichages
608
Phil69970
H
  • Question Question
Microsoft 365 Création application excel
Réponses
5
Affichages
325
Lolote83
L
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…