Number Generator - No Repeats across but duplicated numerous times down

K3BAB87

New Member
Joined
Aug 12, 2016
Messages
1
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
 
Here's my $0.02. Most times it works first time; the most attempts I've seen is 4:

Code:
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
 
Last edited:
Upvote 0
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.

Code:
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
 
Upvote 0

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top