Private Sub Worksheet_Activate()
Dim t, d As Object, i&, a, b, ub&, t1, dbis As Object, j, c, cel As Range, x$, y$, k&
t = Feuil1.[A1].CurrentRegion.Resize(, 2) 'Feuil1 => CodeName
Application.ScreenUpdating = False
Range("A2:G" & Rows.Count).ClearContents 'RAZ
Range(Columns("H"), Columns(Columns.Count)).Delete 'RAZ
If UBound(t) = 1 Then Exit Sub
'---1ère liste (Nb Article)---
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(t)
d(t(i, 2)) = d(t(i, 2)) + 1
Next
a = d.items: b = d.keys: ub = UBound(a)
tri a, b, 0, ub
If ub > 9 Then ub = 9
For i = 0 To UBound(a) 'en cas d'ex aequo en 10ème position
If a(i) < a(ub) Then Exit For
Next
[A2].Resize(i) = Application.Transpose(a)
[B2].Resize(i) = Application.Transpose(b)
[A2].Resize(i, 2).Sort [A2], xlDescending, [B2], , xlAscending, Header:=xlNo 'tri
'---2ème liste (Nb Top10)---
t1 = [A2].Resize(i, 2): ub = UBound(t1)
d.RemoveAll
Set dbis = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(t)
For j = 1 To ub
If t(i, 2) = t1(j, 2) Then
d(t(i, 1)) = d(t(i, 1)) + 1
dbis(t(i, 1)) = dbis(t(i, 1)) & "<" & t(i, 2) & ">"
Exit For
End If
Next j, i
a = d.items: b = d.keys: c = dbis.items
tribis a, b, c, 0, UBound(a)
For i = 0 To UBound(a)
If a(i) < 2 Then Exit For
Next
If i = 0 Then Exit Sub
[D2].Resize(i) = Application.Transpose(a)
[E2].Resize(i) = Application.Transpose(b)
[F2].Resize(i) = Application.Transpose(c)
[D2].Resize(i, 3).Sort [D2], xlDescending, [E2], , xlAscending, Header:=xlNo 'tri
'---3ème liste (Articles)---
With [B1].Resize(ub + 1)
.Copy [H1]
[H1].Resize(, ub + 1) = Application.Transpose(.Value)
End With
Set cel = [H1]
t = [D2].Resize(i, 3)
For i = 3 To ub + 1
x = "<" & cel(i, 1) & ">"
For j = 2 To i - 1
y = "<" & cel(1, j) & ">"
For k = 1 To UBound(t)
cel(i, j) = cel(i, j) + Sgn(InStr(t(k, 3), x) * InStr(t(k, 3), y))
Next k, j, i
'---mise en forme---
With [H1].CurrentRegion
.SpecialCells(xlCellTypeBlanks).Interior.Color = .Cells(1).Interior.Color
.HorizontalAlignment = xlCenter
End With
Columns.AutoFit
Application.Goto [H1], True 'cadrage
End Sub
Sub tri(a, b, gauc, droi) ' Quick sort
Dim ref, g, d, temp
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
temp = b(g): b(g) = b(d): b(d) = temp
g = g + 1: d = d - 1
End If
Loop While g <= d
If g < droi Then Call tri(a, b, g, droi)
If gauc < d Then Call tri(a, b, gauc, d)
End Sub
Sub tribis(a, b, c, gauc, droi) ' Quick sort bis
Dim ref, g, d, temp
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
temp = b(g): b(g) = b(d): b(d) = temp
temp = c(g): c(g) = c(d): c(d) = temp
g = g + 1: d = d - 1
End If
Loop While g <= d
If g < droi Then Call tribis(a, b, c, g, droi)
If gauc < d Then Call tribis(a, b, c, gauc, d)
End Sub
