Global tab1
Option Base 1
Option Explicit
Sub essai()
'=======================================================
' lecture des données
'=======================================================
Dim feuille_datas
Dim feuille_resultats
Dim l, c, l1, c1, l2, c2
Dim nb_ben, nom, b, tmp
feuille_datas = "Data-complète (2)"
l1 = 2 ' première ligne de données
c1 = 7 ' numéro de colonne du premier Bén
nb_ben = 8 ' nombre de colonne Bén
Set tab1 = CreateObject("scripting.dictionary")
' tab1 : tabeau de cumul des données
' On peut le repésenté comme un meuble avec des tirroires
' 0 chatque tittoir on mais une etiquette nom du Bén
' et dedans on y place le contenu de la cellule colonne 6
' avec le caratctère | comme séparateur (*)
With Sheets(feuille_datas) ' avec la feuille des datas
While .Cells(l1, 6) <> "" ' tant que la cellule colonne 6 (Pour synthèse) n'est pas vide
For b = c1 To c1 + nb_ben - 1 ' pour b=colonne 7 à 14 colonnes Bén
nom = .Cells(l1, b) ' récupère le dnom du Bén
If nom <> "" Then ' si non différent de vide
If tab1.exists(nom) Then
tab1(nom) = tab1(nom) & "|" & .Cells(l1, 6) '(*)
Else
tab1(nom) = .Cells(l1, 6)
End If
End If
Next
l1 = l1 + 1 ' ligne suivante
Wend
End With
sort_dictionary tab1
'=======================================================
' écriture résultats
'=======================================================
feuille_resultats = "Resultats"
'----------------------------------------- efface les résultats précédents
Sheets(feuille_resultats).Select
Rows("2:2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
'-----------------------------------------
With Sheets(feuille_resultats)
' travail avec la feuilles résultats
l = 1 ' ligne de début d'écriture de trésultats
c = 1
For Each nom In tab1 ' pour cahque nom dans le tableau
l = l + 1
.Cells(l, c) = nom ' ecriture du nom
tmp = Split(tab1(nom), "|")
For b = 0 To UBound(tmp) ' pour chaque horaire du Bén
l = l + 1
.Cells(l, c + 1) = tmp(b)
Next
Next
End With
End Sub
'==================================================================
Sub sort_dictionary(tab1)
Dim cpt, tmp1, tmp2, tmp3, b1, b2, cle
ReDim tab_tri(1)
cpt = 0
For Each cle In tab1
cpt = cpt + 1
ReDim Preserve tab_tri(cpt)
tab_tri(cpt) = Trim(UCase(cle)) & cle
Next
'-------------------- tri
For b1 = 1 To cpt - 1
tmp1 = tab_tri(b1)
For b2 = b1 + 1 To cpt
tmp2 = tab_tri(b2)
If tmp2 < tmp1 Then
tmp3 = tab_tri(b2)
tab_tri(b2) = tab_tri(b1)
tab_tri(b1) = tmp3
tmp1 = tmp3
End If
Next
Next
'-------------------- regénération dictionary
For b1 = 1 To cpt
tmp1 = tab_tri(b1)
cle = Right(tmp1, Len(tmp1) / 2)
tmp2 = tab1(cle)
tab1.Remove cle
tab1(cle) = tmp2
Next
ReDim tab_tri(1)
End Sub
