Generate truly random numbers in range of cells using VBA

Question

I am trying to randomly allocate the cells in range B4:Z23 of size 20 X 25 i.e. total 500 cells should contain total 500 unique values, the range for random value is 1 to 500. Therefore every number can occur only once in the table. Tried with the code below but it generates duplicates in some cells.

Can anyone help me here ?

Option Explicit
Public Sub Random()

Dim RandomNumber As Integer
Dim i, j As Integer

For j = 2 To 26
Randomize
RandomNumber = Int((500 - 1 + 1) * Rnd + 1)
For i = 4 To 23
With Sheets("Game")
Randomize
RandomNumber = Int((500 - 1 + 1) * Rnd + 1)
Cells(i, j) = RandomNumber
End With
Next i
Next j
End Sub

Answer 1

The original idea of the following code was to keep a Collection of indices 1..n. In a loop, it would choose an index randomly and remove it from the Collection so that the uniqueness would be preserved.
Soon I noticed that Collections are slow in VBA, and that I could use an array as well. The trick here is that after the random selection the last value in the array is saved at the location just chosen, and the index array is shortened by one. The next random choice only needs to be taken from 1..n-1 and will therefore not repeat. It will only choose among available indices. This, along with the use of fast arrays, make this algorithm very fast:

Sub ESPshuffle(ByRef r As Range)
    ' fill the given range with unique random numbers 1..n
    ' where n is the number of cells of the range
    ' 2015-09-20 E/S/P
    ' algorithm: preset a collection with indices 1..n (= unique)
    ' and preserve uniqueness when selecting index at random

    Dim n As Long, nrows As Long, ncols As Long
    Dim i As Long, j As Long, idx As Long
    Dim values() As Long
    Dim arr As Variant

    arr = r  ' range to array, cell content doesnt matter
    nrows = UBound(arr, 1)
    ncols = UBound(arr, 2)
    n = nrows * ncols

    ' preset values, non-random, so unique
    ReDim values(1 To n)
    For i = 1 To n
        values(i) = i
    Next i

    Randomize
    For i = 1 To nrows
        For j = 1 To ncols
            ' choose a random element/index AMONG the remaining
            idx = Int(n * Rnd + 1) ' index in 1..n
            arr(i, j) = values(idx)
            ' remove that element =
            ' preserve the last element in array, then shorten it by 1
            values(idx) = values(n)
            n = n - 1
        Next j
    Next i

    ' fill cells in sheet
    r = arr
End Sub

Calling it with a 5000 cell range

        ESPshuffle Range("B4:Z203")

yields these results, compared to 2 other routines posted here:

Total time in milliseconds, average of 10 repetitions
Santosh:                 231, max 266
Random_dict (J. Simson): 321, max 359
ESPshuffle:               16, max  47

Answer 2

Another dictionary approach, that adjusts dynamically based on initial range

Option Explicit

Public Sub Random1()
    Dim ws As Worksheet, d As Object, max1 As Long, max2 As Long
    Dim i As Long, j As Long, k As Long, arr As Variant

    Set ws = ThisWorkbook.Worksheets("Game")

    arr = ws.Range("B4:Z23")    'adjusts based on this initial range

    max1 = UBound(arr, 1)
    max2 = UBound(arr, 2)

    k = max1 * max2             '<--- 500 (B4:Z23)

    Set d = CreateObject("Scripting.Dictionary")
    Do
        j = Int(((k + 1) * Rnd) + 1)    'Rnd returns a single (decimals)
        If Not d.exists(j) Then
            i = i + 1
            d(j) = i
        End If
    Loop While d.Count < k + 1

    For i = 0 To max1 - 1
        For j = 0 To max2 - 1
            arr(i + 1, j + 1) = d(k)
            k = k - 1
        Next
    Next

    ws.Range("B4:Z23") = arr

End Sub

Answer 3

One more way to go about this, but using a dictionary to check for duplicate values and the modulus operator to place them in the right cells.

     Sub Random()
        Dim r As Integer, i As Integer, n As Integer, dict As Dictionary
        Set dict = New Dictionary
        While n < 525
            r = Int(525 * Rnd + 1)
            If Not dict.Exists(r) Then
                dict(r) = 0
                n = n + 1
                If (n Mod 25) = 0 Then i = i + 1
                Cells((i Mod 21) + 4, (n Mod 25) + 2) = r
            End If
        Wend
     End Sub

Answer 4

Yet another solution, which works by generating a 2D array and shuffling it through swapping randomly selected elements

Sub FillRandomNoRepeat(ByRef r As Range)
    Dim ar() As Integer: ReDim ar(r.Rows.Count - 1, r.Columns.Count - 1)
    Dim i As Integer, j As Integer
    For i = 0 To UBound(ar, 1)
       ar(i, 0) = 1 + i * (1 + UBound(ar, 2))
       For j = 1 To UBound(ar, 2)
        ar(i, j) = 1 + ar(i, j - 1)
       Next
    Next
    ShuffleArray2D ar
    r.Value = ar
End Sub

' This subroutine suffles randomly a bidimensional array, by swapping random elements
Sub ShuffleArray2D(ByRef ar As Variant)
    Randomize
    Dim i1 As Integer, j1 As Integer, i2 As Integer, j2 As Integer, pass As Integer, temp As Integer
    For pass = 0 To (1 + UBound(ar, 1)) * (1 + UBound(ar, 2)) * 5
       i1 = Int((1 + UBound(ar, 1)) * Rnd): j1 = Int((1 + UBound(ar, 2)) * Rnd)
       i2 = Int((1 + UBound(ar, 1)) * Rnd): j2 = Int((1 + UBound(ar, 2)) * Rnd)
       temp = ar(i1, j1): ar(i1, j1) = ar(i2, j2): ar(i2, j2) = temp
    Next
End Sub

Answer 5

Here is a sample for 525 values, the number of cell in B4 through Z24:

Sub Santosh()
   Dim Numbers(1 To 525) As Variant
   Dim i As Long, j As Long, k As Long
   For k = 1 To 525
      Numbers(k) = k
   Next k

   Call Shuffle(Numbers)

   k = 1
   For Each r In Range("B4:Z24")
      r.Value = Numbers(k)
      k = k + 1
   Next r
End Sub

Sub Shuffle(InOut() As Variant)
    Dim HowMany As Long, i As Long, j As Long
    Dim tempF As Double, temp As Variant

    Hi = UBound(InOut)
    Low = LBound(InOut)
    ReDim Helper(Low To Hi) As Double
    Randomize

    For i = Low To Hi
        Helper(i) = Rnd
    Next i


    j = (Hi - Low + 1) \ 2
    Do While j > 0
        For i = Low To Hi - j
          If Helper(i) > Helper(i + j) Then
            tempF = Helper(i)
            Helper(i) = Helper(i + j)
            Helper(i + j) = tempF
            temp = InOut(i)
            InOut(i) = InOut(i + j)
            InOut(i + j) = temp
          End If
        Next i
        For i = Hi - j To Low Step -1
          If Helper(i) > Helper(i + j) Then
            tempF = Helper(i)
            Helper(i) = Helper(i + j)
            Helper(i + j) = tempF
            temp = InOut(i)
            InOut(i) = InOut(i + j)
            InOut(i + j) = temp
          End If
        Next i
        j = j \ 2
    Loop
End Sub

Answer 6

So this code will check each random number generated to see if it is the same as any previous values generated. If so it generates a new random number till it is unique.

Option Explicit
Public Sub Random()

    Dim RandomNumber As Integer
    Dim i, j, k, l As Integer

    Application.ScreenUpdating = False

    For j = 2 To 26
        For i = 4 To 26
            With Sheets("Game")
                Randomize
                RandomNumber = Int(500 * Rnd + 1)
                ' Search through all previous rows & columns (not including the current one)
                For k = 2 To j - 1
                    For l = 4 To i - 1
                        'If the current number is the same as a previous one choose a new one
                        Do While RandomNumber = Cells(l, k)
                            RandomNumber = Int(500 * Rnd + 1)
                        Loop
                        'Once the number is unique place it in the cell
                        Cells(i, j) = RandomNumber
                    Next l
                Next k
            End With
        Next i
    Next j


End Sub