Excel - Organigramme sous VBA

Version imprimable

25/10/2018, 16h29
phaniedano

1 pièce(s) jointe(s)

Excel - Organigramme sous VBA

Bonjour,

J'ai créé sous VBA un organigramme des membres de réunions qui se génère automatiquement en fonction de la réunion sélectionné par une combobox dans le userform. Je me suis aidée des codes VBA accessible sur le site de boisgontier.

Toutefois, est-ce que qqn aurait une idée pour modifier mon code VBA de façon à ce que le positionnement des shapes ne soit pas fixe mais variable en fonction de la taille des shapes précédents.

Par exemple, le 2e shape du niveau 2 est toujours positionné à la ligne 27 quelque soit la taille de l'organigramme, or je voudrais qu'il soit positionné plus haut s'il n'y a pas de shapes précédents du niveau 3. Ou encore, je souhaiterais le positionner juste en dessous de shape du niveau 3 qui dépend du 1er shape du niveau 2.

Autrement dit, est-il possible d'ajouter des lignes de code indiquant un espace maximum entre les shapes de niveau 2 et ceux de niveau 3 ?
Je joins le fichier, ma demande sera plus compréhensible.

Merci pour vos réponses, j'espère que qqn pourra m'aider :(

Bonjour,

Vendredi, c'est du tout cuit :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
Sub verif_Espace()
Dim ShtOrg
Dim ocShape As Shape
Dim MesShape As Shapes
Dim i As Long
Dim monText As String
Dim DownPrec As Single
Dim MonEspace As Single
 
    Set ShtOrg = Sheets("Organigramme")
    Set MesShape = ShtOrg.Shapes
 
    Height = 0
    MonEspace = 10
    For i = 1 To MesShape.Count
        If MesShape.Item(i).Type = msoAutoShape Then
            monText = ""
            On Error Resume Next
                monText = MesShape.Item(i).TextFrame.Characters.Text
            On Error GoTo 0
            If monText <> "" Then
                If DownPrec <> 0 Then
                    MesShape.Item(i).Top = DownPrec + MonEspace
                End If
                DownPrec = MesShape.Item(i).Top + MesShape.Item(i).Height
            End If
        End If
    Next i
 
End Sub

procédure à exécuter en dernier, tu peux faire varier "MonEspace " en ligne 14
bon week

26/10/2018, 19h04
phaniedano

Merci bcp pour la réponse rapide je vais essayer ce Week end,
j'espère que cela va fonctionner...et je te ferai un retour…:D