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
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
|
Sub For_Next_Tableaux()
'Les donnees sont sur Feuil4
Set f4 = Worksheets("Feuil4")
Set dest = Worksheets("Temp")
Set final = Worksheets("Final")
ligfinal = 1
final.Activate
Call For_Next_Niveau0(f4, dest, final)
niveau = 0
recommence = True
Do While recommence = True
dern4 = f4.Cells(Rows.Count, 2).End(xlUp).Row
niveau = niveau + 1
strNiveau = "Niveau" & Format(niveau, "000")
trouvaille = 0
derDest = dest.Cells(Rows.Count, 2).End(xlUp).Row
ligDest = derDest + 1
For i = 1 To derDest
If dest.Cells(i, "B") <> "" Then
Set B = dest.Cells(i, "B")
result1 = B
chaine1 = dest.Cells(i, "C")
valeurC = Right(result1, 1)
For k = 1 To dern4
If f4.Cells(k, "B") = valeurC Then
check = "," & f4.Cells(k, "C").Address & ","
If InStr("," & chaine1 & ",", check) = 0 Then
ajouterC = f4.Cells(k, "C")
If InStr(result1, ajouterC) > 0 Then
dernFinal = final.Cells(Rows.Count, 2).End(xlUp).Row + 1
result = result1 & f4.Cells(k, "C")
chaine = chaine1 & "," & f4.Cells(k, "C").Address
ligfinal = ligfinal + 1
final.Cells(ligfinal, 1) = strNiveau
final.Cells(ligfinal, 2) = result
final.Cells(ligfinal, 3) = chaine
t = Split(chaine, ";")(0)
final.Cells(ligfinal, 4) = Range(t).Row
Else
trouvaille = trouvaille + 1
ligDest = ligDest + 1
result = result1 & f4.Cells(k, "C")
chaine = chaine1 & "," & f4.Cells(k, "C").Address
dest.Cells(ligDest, 2) = result
dest.Cells(ligDest, 3) = chaine
If trouvaille = 1 Then
dest.Cells(ligDest, 1) = strNiveau
End If
End If
End If
End If
Next k
End If
Next i
r = "1:" & derDest
dest.Rows(r).Delete Shift:=xlUp
If trouvaille < 1 Then
recommence = False
End If
Loop
final.Activate
final.Cells(1, 1).Select
MsgBox "Termine"
End Sub
Sub For_Next_Niveau0(f4, dest, final)
dest.Cells.Clear
final.Cells.Clear
final.Cells(1, "D") = "Ligne sur " & f4.Name
ligDest = 1
dern = f4.Cells(Rows.Count, 2).End(xlUp).Row
niveau = 0
strNiveau = "Niveau" & Format(niveau, "000")
trouvaille = 0
For i = 2 To dern
Set B = f4.Cells(i, "B")
Set c = f4.Cells(i, "C")
result1 = B & c
chaine1 = B.Address & "," & c.Address
valeurC = Right(result1, 1)
If f4.Cells(i, "B") <> "" Then
trouvaille = trouvaille + 1
ligDest = ligDest + 1
result = result1
chaine = chaine1
dest.Cells(ligDest, 2) = result
dest.Cells(ligDest, 3) = chaine
If trouvaille = 1 Then
dest.Cells(ligDest, 1) = strNiveau
End If
End If
Next
End Sub |
