Sub TiragesAléatoires()
Dim durée#, n&, ecart As Byte, derlig&, P As Range, Ntirage&
durée = Timer
n = 300 '1000 'nombre de lignes à retenir, à adapter
ecart = 3 'paramétrable
Application.ScreenUpdating = False
derlig = Sheets("base").Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
With Feuil3 'CodeName de la feuille de restitution
.Rows("4:" & .Rows.Count).Delete 'RAZ
Sheets("base").Rows("4:" & derlig).Copy .[A4]
Set P = Intersect(.UsedRange, .Rows("4:" & derlig))
Do 'boucle de recherche du résultat optimal
Application.Calculation = xlCalculationManual
With P.Columns(P.Columns.Count + 1) 'colonne auxiliaire à droite
.Formula = "=RAND()"
.Value = .Value 'supprime les formules
.Cells(1) = 0
Union(P, .Cells).Sort .Cells, xlAscending 'tri
.EntireColumn.Delete 'suppression de la colonne auxiliaire
End With
With .[O5:P10] 'à adapter si nécessaire
.Value = Sheets("liste").[A5:B10].Value 'à adapter si nécessaire
.Copy .Rows(1).Resize(.Rows.Count * (Int(n / .Rows.Count) + 1))
End With
Ntirage = Ntirage + 1
Application.Calculation = xlCalculationAutomatic
Loop While Application.Max(.[B1:L3]) - Application.Min(.[B1:L3]) > ecart
.Rows(n + 5 & ":" & .Rows.Count).Delete
n = .UsedRange.Rows.Count 'ajuste la barre de défilement verticale
.Columns.AutoFit 'ajustement de la largeur des colonnes
.Activate
End With
MsgBox Ntirage & " tirages" & vbLf & vbLf & _
"Durée " & Format(Timer - durée, "0.00 \s"), , "Tirages"
End Sub