Autres Petit defi du jour

Sub Tirages()
Dim t, Ntirages&, N&, Ngroupes%, source, ecart, tirage&, dest(), i&, j%, mini, maxi, s, copiedest()
t = Timer
Ntirages = 10000 'modifiable
N = Application.Count(Columns(2)) 'il ne faut pas de cellules vides
Ngroupes = [E1] 'liste de validation
source = [B2].Resize(N, 2) 'tableau, plus rapide, au moins 2 éléments
ecart = 1E+99
For tirage = 1 To Ntirages
    ReDim dest(1 To N, 1 To Ngroupes) 'RAZ
    For i = 1 To N
        j = Application.RandBetween(1, Ngroupes)
        dest(i, j) = source(i, 1)
    Next i
    mini = 1E+99
    maxi = 0
    For j = 1 To Ngroupes
        s = Application.Sum(Application.Index(dest, 0, j))
        If s < mini Then mini = s
        If s > maxi Then maxi = s
    Next j
    If maxi - mini < ecart Then ecart = maxi - mini: copiedest = dest
Next tirage
'---restitution et mise en forme---
Application.ScreenUpdating = False
[F2].Resize(Rows.Count - 1, Columns.Count - 5).Delete xlUp 'RAZ
[G2].Resize(N, Ngroupes) = copiedest
With [G2].Offset(N)
    .Offset(-1, -1) = "ECART"
    .Offset(, -1) = ecart
    .Resize(, Ngroupes) = "=SUM(R2C:R[-1]C)"
    .Offset(, -1).Interior.Color = vbCyan
    .Resize(, Ngroupes).Interior.Color = vbYellow
    .Offset(, -1).Resize(, Ngroupes + 1).Borders.Weight = xlHairline
End With
With ActiveSheet.UsedRange: End With 'actualise les barres de défilement
Application.ScreenUpdating = True
MsgBox Format(Ntirages, "#,##0") & " tirages réalisés en " & Format(Timer - t, "0.00 \sec"), , "Tirages"
End Sub