Const mn = 15
Const mx = 28
Const rows = 42
Dim dic As Object
Sub generator()
Dim i As Long
Dim j As Long
Dim k As Long
Dim c As Long
Dim try As Long
Dim dict As Object
Set dic = CreateObject("scripting.dictionary")
Set dict = CreateObject("scripting.dictionary")
Range("A1:C1") = Array("Num1", "Num2", "Num3")
Range("A2:C43").ClearContents
k = 2
For c = 1 To 3
Call filldict
Do While i < rows
x = x + 1
j = Int((mx - mn + 1) * Rnd() + mn)
Select Case c
Case 1
dict.Item(j) = dict.Item(j) + 1
If dict.Item(j) < 4 Then
Cells(k, c) = j
k = k + 1
i = i + 1
End If
Case 2
If dict.Item(j) < 3 And Cells(k, c).Offset(, -1) <> j Then
dict.Item(j) = dict.Item(j) + 1
If dict.Item(j) = 3 Then dic.Remove j
Cells(k, c) = j
k = k + 1
i = i + 1
End If
Case 3
If dict.Item(j) < 3 And Cells(k, c).Offset(, -1) <> j And Cells(k, c).Offset(, -2) <> j Then
dict.Item(j) = dict.Item(j) + 1
If dict.Item(j) = 3 Then dic.Remove j
Cells(k, c) = j
k = k + 1
i = i + 1
End If
End Select
Loop
If c = 2 Then
Do While dic.Count > 0
x = x + 1
j = dic.keys()(Int((dic.Count) * Rnd()))
If dict.Item(j) < 3 And Cells(k, c).Offset(, -1) <> j Then
dict.Item(j) = dict.Item(j) + 1
If dict.Item(j) = 3 Then dic.Remove j
Cells(k, c) = j
k = k + 1
i = i + 1
End If
If dic.Count = 1 And j = Cells(k, c).Offset(, -1) Then
try = try + 1
c = c - 1
Exit Do
End If
Loop
ElseIf c = 3 Then
Do While dic.Count > 0
x = x + 1
j = dic.keys()(Int((dic.Count) * Rnd()))
If dict.Item(j) < 3 And Cells(k, c).Offset(, -1) <> j And Cells(k, c).Offset(, -2) <> j Then
dict.Item(j) = dict.Item(j) + 1
If dict.Item(j) = 3 Then dic.Remove j
Cells(k, c) = j
k = k + 1
i = i + 1
End If
If dic.Count < 3 And (j = Cells(k, c).Offset(, -1) Or j = Cells(k, c).Offset(, -2)) Then
try = try + 1
c = c - 1
Exit Do
End If
Loop
End If
k = 2
i = Int(50 * rows / 100)
dic.RemoveAll
dict.RemoveAll
Next
MsgBox "Process completed in " & x & " loops in " & try + 1 & " try", vbInformation
End Sub
Sub filldict()
Dim n As Long
For n = mn To mx
dic.Item(n) = vbEmpty
Next
End Sub