XL 2019 organigramme en VBA

halecs93 · 15 Juin 2023

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

patricktoulon · 16 Juin 2023

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

halecs93 · 16 Juin 2023

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")

halecs93 · 16 Juin 2023

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.

patricktoulon · 16 Juin 2023

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

patricktoulon · 17 Juin 2023

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

Usine à gaz · 17 Juin 2023

Bjr Patrick, le Fil, le Forum

Et celui-là ....
Qiq'c'est qi l'a fait ?

patricktoulon · 17 Juin 2023

Bonjour Lionel
ben je l'avais oublié celui la

Usine à gaz · 17 Juin 2023

patricktoulon à dit:
Bonjour Lionel
ben je l'avais oublié celui la

Ha ! vieillesse quand tu nous tiens lol

Staple1600 · 17 Juin 2023

Bonjour le fil

@halecs93
Si tu suis les directives de la video dont est issu le code VBA :https://www.youtube.com/watch?v=2yml519EWhQ
Notamment quand la video explique la notion de branche.

halecs93 · 17 Juin 2023

patricktoulon à dit:

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
Regarde la pièce jointe 1172691

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

halecs93 · 17 Juin 2023

Usine à gaz à dit:
Bjr Patrick, le Fil, le Forum

Et celui-là ....
Qiq'c'est qi l'a fait ?

Une autre approche...originale.... merci

patricktoulon · 17 Juin 2023

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

Staple1600 · 17 Juin 2023

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

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

)

patricktoulon · 17 Juin 2023

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

XL 2019 organigramme en VBA

XLDnaute Impliqué

Pièces jointes

XLDnaute Barbatruc

XLDnaute Impliqué

XLDnaute Impliqué

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Impliqué

XLDnaute Impliqué

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

Discussions similaires

Partager cette page

Statistiques des forums