Number Generator - No Repeats across but duplicated numerous times down

[K3BAB87]

I am trying to devise a spreadsheet where number generator is used.
I have 3 columns and 42 rows.
In each column, the numbers 15-28 must be used 3 times however going across, it must not be duplicated at all.
How do I do this?

19 28 19
28 17 21
20 17 22
24 20 16
24 28 22

 

[wideboydixon]

Here's my $0.02. Most times it works first time; the most attempts I've seen is 4:

Public Sub DrawThoseNumbers()

Dim bags(2) As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim draw(41, 2) As String
Dim tempBag As String
Dim tryAgain As Boolean
Dim attempts As Long

attempts = 0
Do While True
    ' Another try
    tryAgain = False
    attempts = attempts + 1
    
    ' Set up the bags
    For i = 0 To 2
        bags(i) = ""
        For j = 0 To 41
            bags(i) = bags(i) & CStr(j Mod 14 + 15) & ","
        Next j
    Next i
    
    ' Draw the next numbers
    Erase draw
    For j = 0 To 41
        For i = 0 To 2
            ' Just in case ...
            DoEvents
            
            ' Remove balls already drawn fro this bag
            tempBag = bags(i)
            If i > 0 Then
                For k = 0 To i - 1
                    ' Remove duplicate numbers from this bag
                    tempBag = Replace(tempBag, draw(j, k) & ",", "")
                Next
            End If
            
            ' If we don't have any balls left then we need to start again
            If tempBag = "" Then
                ' We've hit an impossible
                tryAgain = True
                Exit For
            End If
            
            ' Draw a random ball from the bag
            k = Int(Rnd * Len(tempBag) / 3)
            draw(j, i) = Mid(tempBag, k * 3 + 1, 2)
            
            ' Remove this ball from the bag
            k = InStr(bags(i), draw(j, i))
            bags(i) = Left$(bags(i), k - 1) & Mid$(bags(i), k + 3)
        Next i
        If tryAgain Then Exit For
    Next j
    
    If Not tryAgain Then Exit Do
Loop

' Show this draw
For j = 0 To 41
    For i = 0 To 2
        Cells(j + 1, i + 1).Value = draw(j, i)
    Next i
Next j

' How many tries?
MsgBox "Tries: " & CStr(attempts), vbInformation, "DrawThoseNumbers"

End Sub

Using string manipulation isn't ideal but the classes just aren't there in VBA to do what I want.

WBD

 

[Ombir]

Here is my try Using Dictionary:


One thing I noticed that when rows approaching towards end in second and third column, random number generation function isn't much efficient. So to decrease the number of loops, I divided random number generation function in two parts. First for 50 % of rows with initial max/min limit and then second for remaining 50% of rows with new max/min limit with remaining numbers.

By doing this number of loops decreased to average of 190.

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