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
| Sub test_pere_fils_range()
Application.ScreenUpdating = False
Dim Dernligne As Long
Dim suiv As Integer, i As Integer, i2 As Integer, i_res As Integer, cmpt As Integer
Dim montab(), resultat()
Dernligne = Worksheets("BBC").Range("A" & Rows.Count).End(xlUp).Row
'tri du tableau
Range("A2:P" & Dernligne).Sort Key1:=Range("A1"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
montab = Worksheets("BBC").Range("A3:P" & Dernligne).Value 'initialise montab
ReDim resultat(1 To 2 * UBound(montab, 1), 1 To UBound(montab, 2)) 'donne a "resultat" la dimension de montab avec 2 fois plus de ligne
i = 1 'variable qui parcourt les lignes de montab
i_res = 1 'variable qui permet de parcourir les lignes de resultat
cmpt = 0 'compteur pour i
Do While i <= UBound(montab, 1) 'tant qu'on est pas à la fin de montab
For i2 = 1 To 7 'copie les 7 infos de l’objet pere
resultat(i_res, i2) = montab(i, i2)
Next i2
i_res = i_res + 1 'resultat passe à la ligne suivante
suiv = i + 1 'a chaque iteration on initialise suiv comme etant la cellule suivante de i
'existe-t-il une fils (au moins un)
If montab(i, 9) <> "" Then
For i2 = 9 To 16 'copie les 8 infos de l’objet fils
resultat(i_res, i2 - 8) = montab(i, i2) 'ramene les infos des colonnes les plus à droite et les colle à partir de la colonne 1 (d'où le -8)
Next i2
i_res = i_res + 1 'resultat passe à la ligne suivante
If suiv < 650 Then 'teste qui permet de ne pas faire de depassement de capacité sur montab au test suivant lorsque i = Ubound(montab) car suiv=i+1
While montab(suiv, 1) = montab(i, 1)
For i2 = 9 To 16 'copie les 8 infos des objets fils suivants
resultat(i_res, i2 - 8) = montab(suiv, i2) 'ramene les infos des colonnes les plus à droite et les colle à partir de la colonne 1
Next i2
cmpt = cmpt + 1 'compteur pour ne faire des evaluations inutiles en sortie de boucle while
i_res = i_res + 1 'resultat passe à la ligne suivant
suiv = suiv + 1 'variable qui pointe sur la cellule doublon suivante (pour évaluation boucle while)
Wend
End If
End If
i = i + 1 + cmpt 'on repart de i + 1 si pas de doublons (cmpt=0), sinon, on part d'autant plus loin qu'il y en a eu (cmpt non nul).
cmpt = 0 'et on réinitialise cmpt
Loop
Worksheets("Feuil3").Range(Cells(1, 1), Cells(UBound(resultat, 1), UBound(resultat, 2))).Value = resultat 'met le tableau dans la feuille excel
Application.ScreenUpdating = True
'ActiveSheet.Outline.SummaryRow = 0 'mets le '+' en haut
End Sub |
