Option Explicit
Sub Grille_Loto() 'trops long
Dim i%, v#, Rg As Range, j%, k%, n%, c1&, c2%, t%(), b%
Application.ScreenUpdating = False
Sheets.Add
Randomize
Line1:
Cells.ClearContents 'tout effacer si on revient pour la 2ème fois (3ème etc...)
'donner une valeur aléatoire à chaque case
For i = 1 To 18
For j = 1 To 9
Cells(i, j) = Rnd
Next j
Next i
'sélectionner 90 cases avec le bon nombre par colonnes
For j = 1 To 9 'par colonne
'nombres de cases devant contenir des nombres selon la colonne
Select Case j
Case 1
n = 9
Case 2 To 8
n = 10
Case 9
n = 11
End Select
Set Rg = Range(Cells(1, j), Cells(18, j)) 'plage colonne
v = WorksheetFunction.Large(Rg, n) 'trouver nième valeur de la colonne
If WorksheetFunction.CountIf(Rg, v) <> 1 Then GoTo Line1 'si elle est en double recommencer
For i = 1 To 18 'par lignes
If Cells(i, j) < v Then Cells(i, j) = "" 'si la valeur de la cellule < nième valeur, effacer la case
Next i
Next j
'équilibrer les lignes par tirage au sort
For i = 1 To 18 'par lignes
b = 0 'compteur
Do
Set Rg = Range(Cells(i, 1), Cells(i, 9)) 'plage ligne
c1 = WorksheetFunction.Count(Rg) 'nombre de cases par ligne
'selon le nombre de cases par ligne
Select Case c1
Case Is < 5 'il en manque
c2 = Int((9 - c1) * Rnd + 1) 'tirer au sort la case vide à requalifier
c1 = 0 'compteur
For j = 1 To 9 'par colonne
If Cells(i, j) = "" Then c1 = c1 + 1 'si la case est vide, la compter
If c2 = c1 Then 'si correspond au tirage c'est cette case à requalifier
Exit For 'sortir de la boucle (la case à requalifier est en colonne j)
End If
Next j
c2 = 0 'compteur
For k = i + 1 To 18 'par lignes suivantes
'si la ligne a des cases en trops et si la cellule de même colonne que la case à requalifier est non vide
If WorksheetFunction.Count(Range(Cells(k, 1), Cells(k, 9))) > 5 And Cells(k, j) <> "" Then
c2 = c2 + 1 'la compter
'tableau des cases candidates au déplacement
If c2 = 1 Then
ReDim t(1 To 1)
Else
ReDim Preserve t(1 To c2)
End If
t(c2) = k 'la valeur du tableau vaut la ligne de la case candidate
End If
Next k
c1 = Int(c2 * Rnd + 1) 'tirage au sort de la ligne
Cells(i, j) = Cells(t(c1), j) 'la case requalifiée prend la valeur de la case tirée au sort
Cells(t(c1), j) = "" 'la case tirée au sort devient vide
Case Is > 5 'y'en a trops (opérations inverse)
c2 = Int(c1 * Rnd + 1)
c1 = 0
For j = 1 To 9
If Cells(i, j) <> "" Then c1 = c1 + 1
If c2 = c1 Then
Exit For
End If
Next j
c2 = 0
For k = i + 1 To 18
If WorksheetFunction.Count(Range(Cells(k, 1), Cells(k, 9))) < 5 And Cells(k, j) = "" Then
c2 = c2 + 1
If c2 = 1 Then
ReDim t(1 To 1)
Else
ReDim Preserve t(1 To c2)
End If
t(c2) = k
End If
Next k
c1 = Int(c2 * Rnd + 1)
Cells(t(c1), j) = Cells(i, j)
Cells(i, j) = ""
End Select
b = b + 1
If b > 5 Then GoTo Line1 'tout refaire si cette boucle est faite plus de 5 fois pour cette ligne
Loop Until WorksheetFunction.Count(Rg) = 5 'recommencer cette opération si l'ajout ou le retrait n'a pas encore amené le nombre de cases à 5 pour cette ligne
Next i
For j = 1 To 9 'par colonne
Select Case j
'tableau contenant autant de valeurs que de cases par colonne
Case 1
ReDim t(1 To 9)
Case 2 To 8
ReDim t(1 To 10)
Case 9
ReDim t(1 To 11)
End Select
c1 = 0 'compteur
For i = 1 To 18 'par lignes
If Cells(i, j) <> "" Then 'si la cellule est valide
c1 = c1 + 1 'la compter
'donner à la valeur du tableau le rang de la valeur de la case selon la colonne
t(c1) = 10 * (j - 1) + UBound(t) - WorksheetFunction.Rank(Cells(i, j), Range(Cells(1, j), Cells(18, j)))
If j = 1 Then t(c1) = t(c1) + 1 'cas particulier 1ere colonne
End If
Next i
c1 = 0 'compteur
For i = 1 To 18 'par ligne
If Cells(i, j) <> "" Then 'si la cellule est valide
c1 = c1 + 1 'la compter
Cells(i, j) = t(c1) 'remplacer la valeur par le rang
End If
Next i
Next j
'Fioritures
...........
Application.ScreenUpdating = True
End Sub
