Extraction Mise en Ordre (Crack VBA)
4-5-6 niveau de Grade ce serrai énorme !! Mais bon.. Si ce n'est pas possible ce n'est pas grave
Excellente idée les retraits, est-il possible d'en mettre 3 entre chaque Grade ?
Quelque chose comme ça ça irait?
On peut mettre moins en décalage entre les différentes valeurs de grade
EDIT: j'avais mis 2 entre chaque grade mais si tu préfères 3 ça peut se changer très vite!
Le même résultat avec 3 retraits :
Ah j'ai du mal me faire comprendre, 3 retrait c'est nickel je trouve.
Par contre c'est pas le Grade qui doit être décaler mais le Numéro (colonne B)
Et faire disparaître le Grade (colonne A) du coup.. ^^
EDIT: La masquer serait peut être mieux..
Ah d'accord, je t'ai corrigé ça en 2-3 min, voilà le résultat:
Bonjour,
2-3minutes.. Oui c'était très simple... xD
C'est super je crois bien que l'on touche au but !!
Une petite chose, l'intitulé "Flux" se trouve écrit en H6 au lieu de prendre la place de B en H5
Bonjour,
Comme mes mails semblent bloqués dans ma boite d'envoi...
Je te mets le message et le code ici :
Bonjour,
Mon précédent mail n'a apparemment pas voulu s'envoyer donc je vais t'écrire un nouveau mail avec l'ensemble des réponses, en espérant qu'il ne restera pas bloqué dans la boite mail....
J'ai eu un gros soucis avec ton vrai fichier car tu as des références qui reviennent plusieurs fois, et je n'avais pas prévu d'avoir des doublons. Du coup j'ai utilisé les numéros de ligne pour faire le lien entre les enfants et les parents.
Je te transmets le fichier qui est normalement prêt maintenant, il y a juste le cas pour les 15x2 où on peut retrouver du 50x/ parce que le logiciel semble parfois importer des slash au lieu de simplement du vide... Pas pratique...
Sub Synthese()
Application.ScreenUpdating = False
'Déclarations de variables
Dim coef As New Collection, enfant As New Collection, nbgrades As New Collection, posparents As New Collection
Dim TableauTri As Variant, TableauMemoire As Variant, TableauResultat As Variant
Range("a6", "a7").EntireRow.Rows.Delete shift:=xlShiftUp
coef.Add 1, "0" 'collection qui garde les valeurs de coef du grade
enfant.Add 0, "0" 'collection qui garde le numéro de ligne du grade
nbgrades.Add 0, "0"
lig_actu = 1
lig_fin = Range("a" & Rows.Count).End(xlUp).Row
dec_tri = 0
dec_titres = 4
tableau = Range("a" & 2 + dec_titres, "l" & lig_fin)
While lig_actu <= UBound(tableau, 1)
tableau(lig_actu, 12) = lig_actu
'Gestion des collections
'Coefficient
If coef.Count - 1 < tableau(lig_actu, 1) Then
coef.Add coef.Item(CStr(tableau(lig_actu, 1) - 1)) * tableau(lig_actu, 4), CStr(tableau(lig_actu, 1))
Else
coef.Remove CStr(tableau(lig_actu, 1))
coef.Add coef.Item(CStr(tableau(lig_actu, 1) - 1)) * tableau(lig_actu, 4), CStr(tableau(lig_actu, 1))
End If
'Enfant
If enfant.Count - 1 < tableau(lig_actu, 1) Then
enfant.Add lig_actu, CStr(tableau(lig_actu, 1))
Else
enfant.Remove CStr(tableau(lig_actu, 1))
enfant.Add lig_actu, CStr(tableau(lig_actu, 1))
End If
'Affectation nombre d'enfants au tableau
If tableau(lig_actu, 1) > 1 Then
For i = 2 To tableau(lig_actu, 1)
tableau(enfant.Item(CStr(tableau(lig_actu, 1) - i + 1)), 10) = _
tableau(enfant.Item(CStr(tableau(lig_actu, 1) - i + 1)), 10) + 1
tableau(lig_actu, 11) = enfant.Item(CStr(tableau(lig_actu, 1) - 1))
Next i
End If
'Affectation du nombre de points
tableau(lig_actu, 4) = coef.Item(CStr(tableau(lig_actu, 1)))
lig_actu = lig_actu + 1
Wend
'Tri par grade
ReDim TableauTri(LBound(tableau, 1) To UBound(tableau, 1), 1 To 3)
For i = 1 To coef.Count - 1
nb = 0
For h = LBound(TableauTri, 1) To UBound(TableauTri, 1)
If tableau(h, 1) = i Then
nb = nb + 1
'copie des infos nécessaires au tri
TableauTri(1 + dec_tri, 1) = tableau(h, 1)
TableauTri(1 + dec_tri, 2) = tableau(h, 12)
TableauTri(1 + dec_tri, 3) = h
dec_tri = dec_tri + 1
End If
Next h
nbgrades.Add nb, CStr(i)
Next i
'Tri par numéro
ReDim TableauMemoire(1 To 1, 2 To 3)
dec_tri = 0
dec_grade = 0
For i = 1 To coef.Count - 1
While dec_grade < nbgrades(CStr(i)) - 1
Min = 1 + dec_tri + dec_grade
For h = 1 + dec_tri + dec_grade To dec_tri + nbgrades(CStr(i))
If TableauTri(h, 2) < TableauTri(Min, 2) Then
Min = h
End If
Next h
'échange des valeurs en passant par un tableau intermédiaire
TableauMemoire(1, 2) = TableauTri(Min, 2)
TableauMemoire(1, 3) = TableauTri(Min, 3)
TableauTri(Min, 2) = TableauTri(1 + dec_tri + dec_grade, 2)
TableauTri(Min, 3) = TableauTri(1 + dec_tri + dec_grade, 3)
TableauTri(1 + dec_tri + dec_grade, 2) = TableauMemoire(1, 2)
TableauTri(1 + dec_tri + dec_grade, 3) = TableauMemoire(1, 3)
dec_grade = dec_grade + 1
Wend
dec_grade = 0
dec_tri = dec_tri + nbgrades(CStr(i))
Next i
'Repositionnement de l'ensemble du tableau dans un tableau de résultat
ReDim TableauResultat(1 To UBound(tableau, 1), 1 To UBound(tableau, 2) - 3)
lig = 1
dec_synth = 0
numparent = ""
For i = LBound(TableauTri, 1) To UBound(TableauTri, 1)
If tableau(TableauTri(i, 3), 11) <> "" And tableau(TableauTri(i, 3), 11) <> numparent Then
numparent = tableau(TableauTri(i, 3), 11)
dec_synth = posparents(CStr(numparent))
End If
'enregistrement de la position du parent dans la collection
posparents.Add 1 + dec_synth, CStr(TableauTri(i, 2))
'enregistrement du tableau d'origine dans le tableau de résultat
TableauResultat(1 + dec_synth, 1) = tableau(TableauTri(i, 3), 1)
TableauResultat(1 + dec_synth, 2) = tableau(TableauTri(i, 3), 2)
TableauResultat(1 + dec_synth, 3) = tableau(TableauTri(i, 3), 3)
TableauResultat(1 + dec_synth, 4) = tableau(TableauTri(i, 3), 4)
TableauResultat(1 + dec_synth, 5) = tableau(TableauTri(i, 3), 5)
TableauResultat(1 + dec_synth, 6) = tableau(TableauTri(i, 3), 6)
If Replace(tableau(TableauTri(i, 3), 7), " ", "") <> "" And _
Replace(tableau(TableauTri(i, 3), 8), " ", "") <> "" Then
TableauResultat(1 + dec_synth, 7) = tableau(TableauTri(i, 3), 7) & "x" & tableau(TableauTri(i, 3), 8)
Else
TableauResultat(1 + dec_synth, 7) = tableau(TableauTri(i, 3), 7) & tableau(TableauTri(i, 3), 8)
End If
TableauResultat(1 + dec_synth, 8) = tableau(TableauTri(i, 3), 9)
'décalage en fonction de la ligne ajoutée et du nombre d'enfant du numéro
dec_synth = 1 + dec_synth + tableau(TableauTri(i, 3), 10)
Next i
Range("a" & 2 + dec_titres, "i" & lig_fin) = TableauResultat
'Création des espaces avant les grades 1
lig_actu = dec_titres
While lig_actu < lig_fin
'Ajout d'une ligne si besoin
If Cells(lig_actu, 1) = 1 And lig_actu > 2 Then
Cells(lig_actu, 1).EntireRow.Insert (xlShiftUp)
lig_actu = lig_actu + 1
lig_fin = lig_fin + 1
End If
lig_actu = lig_actu + 1
Wend
'Mise en forme du tableau final
Range("i1").EntireColumn.Delete shift:=xlShiftToLeft
'allignement à gauche et mise en place des retraits
Range("b" & 1 + dec_titres, "b" & lig_fin).HorizontalAlignment = xlLeft
For i = 2 + dec_titres To lig_fin
If Cells(i, 1) <> "" Then
Cells(i, 2).IndentLevel = 3 * (Cells(i, 1) - 1)
End If
Next i
Columns("a:a").EntireColumn.Hidden = True
Columns("b:b").EntireColumn.AutoFit
Application.ScreenUpdating = True
End SubC'est superbe c'est encore mieux que ce que j'avais en tête au début et réalisé plus rapidement que ce dont je m'attendais aussi !!
Sincèrement merci beaucoup Ausecour !
De rien
Comme mon message ne veut toujours pas partir de la boite d'envoi je te passer de nouveau le code ici
Sub Synthese()
Application.ScreenUpdating = False
'Déclarations de variables
Dim coef As New Collection, enfant As New Collection, nbgrades As New Collection, posparents As New Collection
Dim TableauTri As Variant, TableauMemoire As Variant, TableauResultat As Variant
Range("a6", "a7").EntireRow.Rows.Delete shift:=xlShiftUp
coef.Add 1, "0" 'collection qui garde les valeurs de coef du grade
enfant.Add 0, "0" 'collection qui garde le numéro de ligne du grade
nbgrades.Add 0, "0"
lig_actu = 1
lig_fin = Range("a" & Rows.Count).End(xlUp).Row
dec_tri = 0
dec_titres = 4
tableau = Range("a" & 2 + dec_titres, "l" & lig_fin)
While lig_actu <= UBound(tableau, 1)
tableau(lig_actu, 12) = lig_actu
'Gestion des collections
'Coefficient
If coef.Count - 1 < tableau(lig_actu, 1) Then
coef.Add coef.Item(CStr(tableau(lig_actu, 1) - 1)) * tableau(lig_actu, 4), CStr(tableau(lig_actu, 1))
Else
coef.Remove CStr(tableau(lig_actu, 1))
coef.Add coef.Item(CStr(tableau(lig_actu, 1) - 1)) * tableau(lig_actu, 4), CStr(tableau(lig_actu, 1))
End If
'Enfant
If enfant.Count - 1 < tableau(lig_actu, 1) Then
enfant.Add lig_actu, CStr(tableau(lig_actu, 1))
Else
enfant.Remove CStr(tableau(lig_actu, 1))
enfant.Add lig_actu, CStr(tableau(lig_actu, 1))
End If
'Affectation nombre d'enfants au tableau
If tableau(lig_actu, 1) > 1 Then
For i = 2 To tableau(lig_actu, 1)
tableau(enfant.Item(CStr(tableau(lig_actu, 1) - i + 1)), 10) = _
tableau(enfant.Item(CStr(tableau(lig_actu, 1) - i + 1)), 10) + 1
tableau(lig_actu, 11) = enfant.Item(CStr(tableau(lig_actu, 1) - 1))
Next i
End If
'Affectation du nombre de points
tableau(lig_actu, 4) = coef.Item(CStr(tableau(lig_actu, 1)))
lig_actu = lig_actu + 1
Wend
'Tri par grade
ReDim TableauTri(LBound(tableau, 1) To UBound(tableau, 1), 1 To 3)
For i = 1 To coef.Count - 1
nb = 0
For h = LBound(TableauTri, 1) To UBound(TableauTri, 1)
If tableau(h, 1) = i Then
nb = nb + 1
'copie des infos nécessaires au tri
TableauTri(1 + dec_tri, 1) = tableau(h, 1)
TableauTri(1 + dec_tri, 2) = tableau(h, 12)
TableauTri(1 + dec_tri, 3) = h
dec_tri = dec_tri + 1
End If
Next h
nbgrades.Add nb, CStr(i)
Next i
'Tri par numéro
ReDim TableauMemoire(1 To 1, 2 To 3)
dec_tri = 0
dec_grade = 0
For i = 1 To coef.Count - 1
While dec_grade < nbgrades(CStr(i)) - 1
Min = 1 + dec_tri + dec_grade
For h = 1 + dec_tri + dec_grade To dec_tri + nbgrades(CStr(i))
If TableauTri(h, 2) < TableauTri(Min, 2) Then
Min = h
End If
Next h
'échange des valeurs en passant par un tableau intermédiaire
TableauMemoire(1, 2) = TableauTri(Min, 2)
TableauMemoire(1, 3) = TableauTri(Min, 3)
TableauTri(Min, 2) = TableauTri(1 + dec_tri + dec_grade, 2)
TableauTri(Min, 3) = TableauTri(1 + dec_tri + dec_grade, 3)
TableauTri(1 + dec_tri + dec_grade, 2) = TableauMemoire(1, 2)
TableauTri(1 + dec_tri + dec_grade, 3) = TableauMemoire(1, 3)
dec_grade = dec_grade + 1
Wend
dec_grade = 0
dec_tri = dec_tri + nbgrades(CStr(i))
Next i
'Effacement de la feuille
Range("a" & 2 + dec_titres, "i" & lig_fin).ClearContents
'Repositionnement de l'ensemble du tableau dans un tableau de résultat
ReDim TableauResultat(1 To UBound(tableau, 1), 1 To UBound(tableau, 2) - 3)
lig = 1
dec_synth = 0
numparent = ""
For i = LBound(TableauTri, 1) To UBound(TableauTri, 1)
If tableau(TableauTri(i, 3), 11) <> "" And tableau(TableauTri(i, 3), 11) <> numparent Then
numparent = tableau(TableauTri(i, 3), 11)
dec_synth = posparents(CStr(numparent))
End If
'enregistrement de la position du parent dans la collection
posparents.Add 1 + dec_synth, CStr(TableauTri(i, 2))
'enregistrement du tableau d'origine dans le tableau de résultat
TableauResultat(1 + dec_synth, 1) = tableau(TableauTri(i, 3), 1)
TableauResultat(1 + dec_synth, 2) = tableau(TableauTri(i, 3), 2)
TableauResultat(1 + dec_synth, 3) = tableau(TableauTri(i, 3), 3)
TableauResultat(1 + dec_synth, 4) = tableau(TableauTri(i, 3), 4)
TableauResultat(1 + dec_synth, 5) = tableau(TableauTri(i, 3), 5)
TableauResultat(1 + dec_synth, 6) = tableau(TableauTri(i, 3), 6)
If Replace(tableau(TableauTri(i, 3), 7), " ", "") <> "" And _
Replace(tableau(TableauTri(i, 3), 8), " ", "") <> "" Then
TableauResultat(1 + dec_synth, 7) = tableau(TableauTri(i, 3), 7) & "x" & tableau(TableauTri(i, 3), 8)
Else
TableauResultat(1 + dec_synth, 7) = tableau(TableauTri(i, 3), 7) & tableau(TableauTri(i, 3), 8)
End If
TableauResultat(1 + dec_synth, 8) = tableau(TableauTri(i, 3), 9)
'décalage en fonction de la ligne ajoutée et du nombre d'enfant du numéro
dec_synth = 1 + dec_synth + tableau(TableauTri(i, 3), 10)
Next i
Range("a" & 2 + dec_titres, "i" & lig_fin) = TableauResultat
'Création des espaces avant les grades 1
lig_actu = dec_titres
While lig_actu < lig_fin
'Ajout d'une ligne si besoin
If Cells(lig_actu, 1) = 1 And lig_actu > 2 + dec_titres Then
Cells(lig_actu, 1).EntireRow.Insert (xlShiftUp)
lig_actu = lig_actu + 1
lig_fin = lig_fin + 1
End If
lig_actu = lig_actu + 1
Wend
'allignement à gauche et mise en place des retraits
Range("b" & 1 + dec_titres, "b" & lig_fin).HorizontalAlignment = xlLeft
For i = 2 + dec_titres To lig_fin
If Cells(i, 1) <> "" Then
Cells(i, 2).IndentLevel = 3 * (Cells(i, 1) - 1)
End If
Next i
Columns("a:a").EntireColumn.Hidden = True
Columns("b:b").EntireColumn.AutoFit
Application.ScreenUpdating = True
End SubC'est le TOP !!!!
Merci Beaucoup.
Bonjour,
Je t'ai envoyé un message de réponse (enfin), il est actuellement dans ma boite d'envoi, tu devrais le recevoir dans la journée
A bientôt sur le forum!
Rebonjour,
Le message est toujours en boîte d'envoi du coup je te le transmets ici :
Bonjour,
Désolé pour le délai de réponse, j'étais en séminaire puis en vacances, donc loin du forum!
Je me suis penché sur le problème que tu m'avais donné, et... J'ai mis du temps à trouver d'où venais le bug mais c'est bon, je vais pouvoir te l'expliquer en détail.
En fait, dans l'exemple que tu m'avais donné pour le programme, on avait de la chance, les références se suivaient bien et donc pas de soucis. J'enregistrai le nombre de références qui se trouvaient en dessous de la référence actuelle dans dec_synth, comme la référence qui suivait avait le même parent, on prenait le dec_synth et hop, on avait le décalage entre les références qui permettaient de mettre les "enfants" en dessous. Le soucis c'est que là... Les références qui ont le même parent ne sont pas à la suite, et comme je n'enregistrais pas le décalage pour mettre les enfants dans la position du parent, mon dec_synth ne servait plus à rien...
Dans mon algorithme, soit on a le même parent et on utilise dec_synth, soi on va chercher la position du parent, mais je ne touchais plus à la position du parent, donc tu passe sur la référence 2709400, tu ajoute 6 au dec_synth, tu passes à une référence qui n'a pas le même parent, tu réinitialise tout, puis quand tu reviens à une référence qui a le même parent, tu décales juste de 1 par rapport à la référence 2709400 alors qu'il faudrait beaucoup plus en place. Du fait de cette erreur, le programme écrivait sur des lignes qui étaient déjà prises car mal placées...
Le problème est corrigé et ne devrait plus arriver, je te souhaite un bon début d'année et mes meilleurs voeux
EDIT:
fichier supprimé sur demande de Sebyg
Je te transmets le fichier avec les corrections et le résultat