Sub Classer()
Dim t, ncol%, P As Range, rc&, titre, titre1, j%, x$, pos%, i&, tablo
Dim d1 As Object, d2 As Object, d3 As Object, d4 As Object, d5 As Object, d6 As Object, d7 As Object, d8 As Object, d9 As Object
t = Timer
ncol = 9905 'colonne NPY
Set P = Sheets("BD").UsedRange.Resize(, ncol)
rc = P.Rows.Count
'---ligne de titres---
titre = P.Rows(1) 'matrice, plus rapide
titre1 = titre
For j = 12 To ncol
x = titre(1, j)
If x <> "" Then
pos = InStr(x, "/")
titre1(1, j) = Left(x, pos)
End If
Next j
'---analyse du tableau source---
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set d3 = CreateObject("Scripting.Dictionary")
Set d4 = CreateObject("Scripting.Dictionary")
Set d5 = CreateObject("Scripting.Dictionary")
Set d6 = CreateObject("Scripting.Dictionary")
Set d7 = CreateObject("Scripting.Dictionary")
Set d8 = CreateObject("Scripting.Dictionary")
Set d9 = CreateObject("Scripting.Dictionary")
For i = 2 To rc
If i Mod 50 = 0 Then Application.StatusBar = Format((Timer - t) / 86400, "hh:mm:ss") & " - " & Int(100 * i / rc) & "%"
tablo = P.Rows(i) 'matrice, plus rapide
For j = 12 To ncol
x = titre(1, j)
If x <> "" Then
If tablo(1, j) = 1 Then
Select Case titre1(1, j)
Case "1/": d1(x) = d1(x) + 1
Case "2/": d2(x) = d2(x) + 1
Case "3/": d3(x) = d3(x) + 1
Case "4/": d4(x) = d4(x) + 1
Case "5/": d5(x) = d5(x) + 1
Case "6/": d6(x) = d6(x) + 1
Case "7/": d7(x) = d7(x) + 1
Case "8/": d8(x) = d8(x) + 1
Case "9/": d9(x) = d9(x) + 1
End Select
End If
End If
Next j, i
'---restitution---
Application.ScreenUpdating = False
On Error Resume Next 'si un Dictionary est vide
With Sheets("Classement")
If .FilterMode Then .ShowAllData 'si la feuille est filtrée
.Rows("2:" & .Rows.Count).ClearContents 'RAZ
For j = 2 To 26 Step 3
Select Case 1 + (j - 2) / 3
Case 1
.Cells(2, j).Resize(d1.Count) = Application.Transpose(d1.keys) 'Transpose est limitée à 65536 lignes
.Cells(2, j + 1).Resize(d1.Count) = Application.Transpose(d1.items)
.Cells(2, j).Resize(d1.Count, 2).Sort .Cells(2, j + 1), xlDescending, Header:=xlNo 'tri décroissant
Case 2
.Cells(2, j).Resize(d2.Count) = Application.Transpose(d2.keys)
.Cells(2, j + 1).Resize(d2.Count) = Application.Transpose(d2.items)
.Cells(2, j).Resize(d2.Count, 2).Sort .Cells(2, j + 1), xlDescending, Header:=xlNo
Case 3
.Cells(2, j).Resize(d3.Count) = Application.Transpose(d3.keys)
.Cells(2, j + 1).Resize(d3.Count) = Application.Transpose(d3.items)
.Cells(2, j).Resize(d3.Count, 2).Sort .Cells(2, j + 1), xlDescending, Header:=xlNo
Case 4
.Cells(2, j).Resize(d4.Count) = Application.Transpose(d4.keys)
.Cells(2, j + 1).Resize(d4.Count) = Application.Transpose(d4.items)
.Cells(2, j).Resize(d4.Count, 2).Sort .Cells(2, j + 1), xlDescending, Header:=xlNo
Case 5
.Cells(2, j).Resize(d5.Count) = Application.Transpose(d5.keys)
.Cells(2, j + 1).Resize(d5.Count) = Application.Transpose(d5.items)
.Cells(2, j).Resize(d5.Count, 2).Sort .Cells(2, j + 1), xlDescending, Header:=xlNo
Case 6
.Cells(2, j).Resize(d6.Count) = Application.Transpose(d6.keys)
.Cells(2, j + 1).Resize(d6.Count) = Application.Transpose(d6.items)
.Cells(2, j).Resize(d6.Count, 2).Sort .Cells(2, j + 1), xlDescending, Header:=xlNo
Case 7
.Cells(2, j).Resize(d7.Count) = Application.Transpose(d7.keys)
.Cells(2, j + 1).Resize(d7.Count) = Application.Transpose(d7.items)
.Cells(2, j).Resize(d7.Count, 2).Sort .Cells(2, j + 1), xlDescending, Header:=xlNo
Case 8
.Cells(2, j).Resize(d8.Count) = Application.Transpose(d8.keys)
.Cells(2, j + 1).Resize(d8.Count) = Application.Transpose(d8.items)
.Cells(2, j).Resize(d8.Count, 2).Sort .Cells(2, j + 1), xlDescending, Header:=xlNo
Case 9
.Cells(2, j).Resize(d9.Count) = Application.Transpose(d9.keys)
.Cells(2, j + 1).Resize(d9.Count) = Application.Transpose(d9.items)
.Cells(2, j).Resize(d9.Count, 2).Sort .Cells(2, j + 1), xlDescending, Header:=xlNo
End Select
.Columns.AutoFit 'ajustement largeurs
Next j
End With
Application.ScreenUpdating = True
MsgBox "Classement effectué en " & Format(Timer - t, "0.00 \sec")
End Sub