Private Sub Worksheet_Activate()
Dim F As Worksheet, d As Object, nlig&, c As Range, n&, a, b, ncol%, i&, j%
Set F = Sheets("Source")
'---nombre de points par affaire---
Set d = CreateObject("Scripting.Dictionary")
With F.[A1].CurrentRegion
nlig = .Rows.Count - 1
If .Columns.Count > 2 Then
For Each c In .Offset(, 2).Resize(, .Columns.Count - 2)
If c <> "" Then n = n + 1: d(c.Value) = d(c.Value) + 1 'comptage
Next c
End If
End With
'---équilibrage---
Application.ScreenUpdating = False
Cells.Delete 'RAZ
F.Columns("A:B").Copy [A1]
If n = 0 Then Exit Sub 'sécurité
a = d.items: b = d.keys
Tri a, b, 0, UBound(a) 'tri décroissant
ncol = Application.RoundUp(n / nlig, 0)
For i = 0 To UBound(a)
For Each c In Range("C2").Resize(nlig, ncol)
If c = "" And a(i) <= nlig + 2 - c.Row Then
c.Resize(a(i)) = b(i)
GoTo 2
End If
Next c
1 For Each c In Cells(2, ncol + 3 + j).Resize(nlig) 'ajoute une colonne supplémentaire
If c = "" And a(i) <= nlig + 2 - c.Row Then
c.Resize(a(i)) = b(i)
GoTo 2
End If
Next c
j = j + 1
GoTo 1
2 Next i
Columns.AutoFit 'ajustement largeurs
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