Option Explicit
Public Const Col_Ville As Byte = 6, Col_Ami As Byte = 7, Col_Niveau As Byte = 5
Public Dic_Ville As Object
Public NbCol As Integer
'
Sub Construire_Dic()
Dim Lo As ListObject
Dim Tb_Val, NbLgn As Long, Tb, Opér
Dim Ville As String, Ami As String, Niveau As Integer
Dim KVille, KAmi, KNiv, Col
Dim i As Long, j As Long
Set Lo = Sh_BdD.ListObjects(1)
NbLgn = Lo.ListRows.Count
NbCol = Lo.ListColumns.Count
If NbLgn < 1 Then Exit Sub 'le tableau source est vide, on sort
Tb_Val = Lo.DataBodyRange.Value
'______________________
'Constitution des dicos
'1ère passe toutes les clefs (avec seulement N° des lignes)
Set Dic_Ville = CreateObject("Scripting.Dictionary")
For i = 1 To NbLgn
Ville = Tb_Val(i, Col_Ville): Ami = Tb_Val(i, Col_Ami): Niveau = Tb_Val(i, Col_Niveau)
If Not Dic_Ville.Exists(Ville) Then Set Dic_Ville(Ville) = CreateObject("Scripting.Dictionary")
If Not Dic_Ville(Ville).Exists(Ami) Then Set Dic_Ville(Ville)(Ami) = CreateObject("Scripting.Dictionary")
If Dic_Ville(Ville)(Ami).Exists(Niveau) Then
Dic_Ville(Ville)(Ami)(Niveau) = Dic_Ville(Ville)(Ami)(Niveau) & ";" & i
Else
Dic_Ville(Ville)(Ami)(Niveau) = i
End If
Next i
'2ème passe tableaux complets pour tous les niveaux
For Each KVille In Dic_Ville.Keys
For Each KAmi In Dic_Ville(KVille).Keys
For Each KNiv In Dic_Ville(KVille)(KAmi).Keys
Tb = Split(Dic_Ville(KVille)(KAmi)(KNiv), ";")
NbLgn = UBound(Tb) + 1
ReDim Tb_Temp(1 To NbLgn, 1 To NbCol)
For i = 1 To NbLgn
For j = 1 To NbCol
Tb_Temp(i, j) = Tb_Val(Tb(i - 1), j)
Next j
Next i
Dic_Ville(KVille)(KAmi)(KNiv) = Tb_Temp
Next KNiv, KAmi, KVille
'Les dicos sont constitués
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
'Préparation du formulaire
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
'Opérateurs de comparaison
Opér = Array("=", "<>", ">=", ">", "<=", "<")
'liste des villes triées
Tb = Dic_Ville.Keys
Tri Tb, LBound(Tb), UBound(Tb)
With UsF_Critères
.CBx_Opérateurs.List = Opér
.CBx_Ville.List = Tb
'Préparation de la ListView
With .LVw_Etat
With .ColumnHeaders
'Supprime les anciens entêtes
.Clear
'Création des entêtes en spécifiant leur largeur
For Each Col In Lo.HeaderRowRange.Cells
.Add , , Col.Value, Col.EntireColumn.Width * 1.45
Next
End With
'type d'affichage de la listview (tableau)
.View = lvwReport
.Gridlines = True
End With
.Show
End With
Unload UsF_Critères
Dic_Ville.RemoveAll
Set Dic_Ville = Nothing
End Sub
Sub Tri(a, gauc, droi) ' QuickSort http://boisgontierj.free.fr
Dim ref, temp, g, d
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
Do While a(g) < ref: g = g + 1: Loop
Do While ref < a(d): d = d - 1: Loop
If g <= d Then
temp = a(g): a(g) = a(d): a(d) = temp
g = g + 1: d = d - 1
End If
Loop While g <= d
If g < droi Then Call Tri(a, g, droi)
If gauc < d Then Call Tri(a, gauc, d)
End Sub
Sub Vider_LObj()
Dim Lo As ListObject
Set Lo = Sh_Extrait.ListObjects(1)
With Lo.Range
.Offset(1).Resize(.Rows.Count - 1).Clear
End With
Lo.Resize Lo.HeaderRowRange.Resize(2)
End Sub