XL 2010 Répartition dans des groupes sous contraintes

Sub Tirages()
Dim Ngroupe%, tablo, ub%, d As Object, ecart%, tirage&, i%, x$, memo, e%
Ngroupe = [F2] 'à adapter
tablo = [A1].CurrentRegion
ub = UBound(tablo)
Set d = CreateObject("Scripting.Dictionary")
Randomize
Application.ScreenUpdating = False
ecart = 100
For tirage = 1 To 2000
    d.RemoveAll 'RAZ
    For i = 2 To ub
        Do
            tablo(i, 4) = Application.RandBetween(1, Ngroupe)
            x = tablo(i, 3) & tablo(i, 4)
        Loop While d.exists(x)
        d(x) = ""
    Next i
    memo = Range("D1").Resize(ub)
    Range("D1").Resize(ub) = Application.Index(tablo, , 4)
    e = Application.Max(Range("H2:AA2")) - Application.Min(Range("H2:AA2"))
    If e < ecart Then ecart = e Else Range("D1").Resize(ub) = memo
Next tirage
End Sub

Sub Groupes()
Dim t, nbg#, i&, n&, k&, aux
   On Error GoTo FIN:
   Application.ScreenUpdating = False
   With Sheets("Feuil1")
      .Select
      If [g1] = "" Then Exit Sub Else nbg = [g1]
      If [e1] = "TempAuxE" Then [e1].EntireColumn.Delete
      Columns("e:e").Insert: [e1] = "TempAuxE"
      If .FilterMode Then .ShowAllData
      t = [a1].CurrentRegion
      Randomize: For i = 2 To UBound(t): t(i, 5) = Rnd: Next
      [a1].Resize(UBound(t), UBound(t, 2)) = t
      [a1].CurrentRegion.Sort key1:=[e1], order1:=xlAscending, MatchCase:=False, Header:=xlYes
      [a1].CurrentRegion.Sort key1:=[c1], order1:=xlAscending, MatchCase:=False, Header:=xlYes
      [e2].Resize(UBound(t) - 1).FormulaLocal = "=SI(C2<>C1;ALEA();E1)"
      [a1].CurrentRegion.Sort key1:=[e1], order1:=xlAscending, MatchCase:=False, Header:=xlYes
      t = [a1].CurrentRegion: n = 1 + Int(Rnd * nbg)
      For i = 2 To UBound(t)
         n = n + 1: If n = nbg + 1 Then n = 1
         t(i, 4) = n
      Next i
      ReDim r(1 To nbg)
      For i = 1 To nbg: r(i) = i: Next
      For i = 1 To nbg: k = 1 + Int(Rnd * nbg): aux = r(i): r(i) = r(k): r(k) = aux: Next i
      For i = 2 To UBound(t): t(i, 4) = r(t(i, 4)): Next
      [a1].Resize(UBound(t), UBound(t, 2)) = t
      [a1].CurrentRegion.Sort key1:=[c1], order1:=xlAscending, MatchCase:=False, Header:=xlYes, _
         key2:=[d1], order2:=xlAscending
FIN:
      If [e1] = "TempAuxE" Then [e1].EntireColumn.Delete
   End With
End Sub

Sub Tirages()
Dim t, Ngroupe%, Ntirage&, tablo, ub%, dx As Object, dy As Object, dz As Object
Dim ecart%, tirage&, i%, x$, test As Boolean, y$, z$, a, e%, memo, n
t = Timer
Ngroupe = [F2] 'à adapter
Ntirage = 2000 'à adapter
tablo = [A1].CurrentRegion
ub = UBound(tablo)
Set dx = CreateObject("Scripting.Dictionary")
Set dy = CreateObject("Scripting.Dictionary")
Set dz = CreateObject("Scripting.Dictionary")
ecart = 100
Randomize
For tirage = 1 To Ntirage
    dx.RemoveAll 'RAZ
    dy.RemoveAll 'RAZ
    dz.RemoveAll 'RAZ
    For i = 2 To ub
        x = tablo(i, 3)
        test = dx(x) < Ngroupe
        Do
            tablo(i, 4) = 1 + Int(Ngroupe * Rnd) 'aléatoire
            y = tablo(i, 4)
            z = x & y
        Loop While dz.exists(z) And test
        dx(x) = dx(x) + 1
        dy(y) = dy(y) + 1
        dz(z) = ""
    Next i
    a = dy.items
    e = Application.Max(a) - Application.Min(a)
    If e < ecart Then
        ecart = e
        memo = Application.Index(tablo, , 4)
        n = n + 1
    End If
Next tirage
[D1].Resize(ub) = memo 'restitution
MsgBox Ntirage & " tirages en " & Format(Timer - t, "0.00 \sec") & vbLf & vbLf & "Ecart " & ecart & " avec " & n & " améliorations"
End Sub