Discussion :

[jbesclapez]

Bonjour Mr Boigontier,

D'abord un grand merci pour votre site! Une petite pepite. Et doublement merci pour partager cela avec nous!

J ai utilise votre script dans la feuille excel ArbreTableau.xls de votre site et j ai un leger probleme.
Le script ne fonctionne pas quand un fils a plusieurs peres.

Voici le script dont je parle :
Pouvez vous me dire quoi faire pour que cela fonctionne?
Merci encore!

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
Dim colonne, débutOrg, fbd, inth, intv
Dim Tbl(1 To 100, 1 To 4)
Dim n, branche
Sub CreeOrga()
   Set f = Sheets("bd")
   For i = 1 To 100: For k = 1 To 4: Tbl(i, k) = "": Next k: Next i
   n = 0
   For i = 2 To f.[A65000].End(xlUp).Row
    Ajout f.Cells(i, 1), f.Cells(i, 2), f.Cells(i, 3)
   Next i
   DessineBrancheShapes Tbl(1, 1), "orga1"
   DessineBrancheShapes "bb", "orga2"
   Sheets("orga1").Select
End Sub
Sub CreeOrga2()
   Set f = Sheets("bd")
   For i = 1 To 100: For k = 1 To 4: Tbl(i, k) = "": Next k: Next i
   n = 0
   For i = 2 To f.[A65000].End(xlUp).Row
    Ajout f.Cells(i, 1), f.Cells(i, 2), f.Cells(i, 3)
   Next i
   DessineBrancheShapes "bb", "orga2"
   'SupBranche "bb"
   'DessineBrancheShapes "aa", "orga2"
End Sub
Sub Ajout(Fils, Père, Attribut)
  n = n + 1
  Tbl(n, 1) = Fils: Tbl(n, 2) = Père: Tbl(n, 3) = Attribut
End Sub
Sub DessineBrancheShapes(Père, feuille)
   Set fbd = Sheets(feuille)
   For Each s In fbd.Shapes
    If s.Type = 17 Or s.Type = 1 Then s.Delete
   Next
   Set débutOrg = fbd.Range("c4")
   colonne = 0
   inth = 50
   intv = 40
   créeShape Père, 1, Attribut(Père)
End Sub
Sub créeShape(parent, niv, Attribut) ' procédure récursive
  hauteurshape = 27
  largeurshape = 50
  colonne = colonne + 1
  fbd.Shapes.AddTextbox(msoTextOrientationHorizontal, 10, 10, largeurshape, hauteurshape).Name = parent
  fbd.Shapes(parent).Line.ForeColor.SchemeColor = 22
  txt = parent & vbLf & Attribut
  With fbd.Shapes(parent)
    .TextFrame.Characters.Text = txt
    .TextFrame.Characters(Start:=1, Length:=1000).Font.Size = 8
    .TextFrame.Characters(Start:=1, Length:=Len(parent)).Font.Bold = True
    .Fill.ForeColor.RGB = RGB(255, 255, 255)
    .TextFrame.Characters(Start:=1, Length:=Len(parent)).Font.Color = vbRed
  End With
  fbd.Shapes(parent).Left = débutOrg.Left + inth * colonne
  fbd.Shapes(parent).Top = débutOrg.Top + intv * (niv - 1)
  For i = 1 To n
    If Tbl(i, 1) = parent And niv > 1 Then
      shapePère = Tbl(i, 2)
      fbd.Shapes.AddConnector(msoConnectorElbow, 100, 100, 100, 100).Name = parent & "c"
      fbd.Shapes(parent & "c").Line.ForeColor.SchemeColor = 22
      fbd.Shapes(parent & "c").ConnectorFormat.BeginConnect fbd.Shapes(shapePère), 3
      fbd.Shapes(parent & "c").ConnectorFormat.EndConnect fbd.Shapes(parent), 1
   End If
   If Tbl(i, 2) = parent Then créeShape Tbl(i, 1), niv + 1, Tbl(i, 3)
  Next i
End Sub
Function Attribut(Fils)
   For i = 1 To n
     If Tbl(i, 1) = Fils Then Attribut = Tbl(i, 3)
   Next i
End Function
Function affiche()
  tmp = ""
  For p = 1 To n
   If Tbl(p, 1) <> "" Then tmp = tmp & "Fils:" & Tbl(p, 1) & " - père:" & Tbl(p, 2) & vbLf
  Next p
  affiche = tmp
End Function
Function Père(Fils)
   For i = 1 To n
     If Tbl(i, 1) = Fils Then Père = Tbl(i, 2)
   Next i
End Function
Function taille()
  taille = n
End Function
Sub SupItem(parent, niv)       ' procédure récursive
  For i = 1 To n
    If Tbl(i, 2) = parent Then SupItem Tbl(i, 1), niv + 1
  Next i
  For k = 1 To n
   If Tbl(k, 1) = parent Then Tbl(k, 4) = "sup"
  Next k
End Sub
Sub SupBranche(Père)
   SupItem Père, 1
   For i = n To 1 Step -1
     If Tbl(i, 4) = "sup" Then
        For k = i To n
           For c = 1 To 4: Tbl(k, c) = Tbl(k + 1, c): Next c
        Next k
        n = n - 1
     End If
   Next i
End Sub
'Sub DessineOrga()
'   Set forga = Sheets("orga")
'   Set f = Sheets("bd")
'   Tbl = f.Range("A2:C" & f.[A65000].End(xlUp).Row).Value
'   n = UBound(Tbl)
'   For Each s In forga.Shapes
'    If s.Type = 17 Or s.Type = 1 Then s.Delete
'   Next
'   inth = 70
'   intv = 60
'   colonne = 0
'   Set débutOrg = forga.Range("c4")
'   créeShape Tbl(1, 1), 1, Tbl(1, 3)
'End Sub