Admin
1
Sub Button3_Click()
Dim FillRange As Range, c As Range
Set FillRange = Range("A1:A10")
For x = 0 To 4
Set FillRange = Range("A1:A10").Offset(, x)
For Each c In FillRange
Do
c.Value = Int((50 - 1 + 1) * Rnd + 1)
Loop Until WorksheetFunction.CountIf(FillRange, c.Value) < 2
Next
Next
End Sub
"Random sort" approach:
Sub tester()
Dim arr, newArr
arr = Application.Transpose(Application.Evaluate("ROW(1:50)")) 'array 1 to 50
Debug.Print "Original:" & vbLf & Join(arr, vbLf)
SortSpecial arr, "RandomVal"
Debug.Print "Rearranged:" & vbLf & Join(arr, vbLf)
'put arr into the worksheet...
End Sub
'Sorts an array using some specific translation defined in `func`
Sub SortSpecial(list, func As String)
Dim First As Long, Last As Long, i As Long, j As Long, tmp, arrComp()
First = LBound(list)
Last = UBound(list)
'fill the "compare array...
ReDim arrComp(First To Last)
For i = First To Last
arrComp(i) = Application.Run(func, list(i))
Next i
'now sort by comparing on `arrComp` not `list`
For i = First To Last - 1
For j = i + 1 To Last
If arrComp(i) > arrComp(j) Then
tmp = arrComp(j) 'swap positions in the "comparison" array
arrComp(j) = arrComp(i)
arrComp(i) = tmp
tmp = list(j) '...and in the original array
list(j) = list(i)
list(i) = tmp
End If
Next j
Next i
End Sub
Function RandomVal(v)
RandomVal = Rnd()
End Function
Alternatively, if one has Microsoft365, this is quite possibly through a single (though volatile) formula:
Formula in A1:
=INDEX(SORTBY(SEQUENCE(50),RANDARRAY(50)),SEQUENCE(10,5))
Some explanation:
Step-1: SEQUENCE(50) - Retrieve an array from 1-50 (so no duplicates).
Step-2: RANDARRAY(50) - Retrieve an array of 50 random values.
Step-3: SORTBY(Step1,Step2) - Sort the 1st array according to the 2nd to create a total random set of values from 1-50 without duplicates.
Step-4: INDEX(Step3, SEQUENCE(10,5)) - We can now "slice" our array in chunks of 10 rows over 5 columns.
This will 'randomly' put the values 1 to 50 into A1:E10 without repetition.
Sub Button3_Click()
Dim rw As Long
Dim cl As Long
Dim num As Long
num = 1
Do
rw = Application.RandBetween(1, 10)
cl = Application.RandBetween(1, 5)
If Cells(rw, cl).Value = "" Then
Cells(rw, cl) = num
num = num + 1
End If
Loop Until Application.CountBlank(Range("A1:E10")) = 0
End Sub
Option Explicit
Sub writeRandomRange()
Const CellAddress As String = "A1"
Const First As Long = 1
Const Last As Long = 50
Const rCount As Long = 10
Const cCount As Long = 5
If Last - First + 1 >= rCount * cCount Then
Dim arr As Variant: arr = RandomDictionaryToArray(First, Last)
Dim Data() As Long: ReDim Data(1 To rCount, 1 To cCount)
Dim r As Long, c As Long, n As Long
For r = 1 To rCount
For c = 1 To cCount
Data(r, c) = arr(n)
n = n + 1
Next c
Next r
Range(CellAddress).Resize(rCount, cCount).Value = Data
Else
MsgBox "There are not enough numbers.", vbCritical, "Fail"
End If
End Sub
Function RandomDictionaryToArray( _
ByVal LowOrHigh As Long, _
ByVal HighOrLow As Long) _
As Variant
' Define the Numbers Dictionary ('dict').
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
' Define the lower number ('Minimum') and the Number of Elements ('NoE').
Dim NoE As Long
Dim Minimum As Long
If LowOrHigh < HighOrLow Then
Minimum = LowOrHigh
NoE = HighOrLow - LowOrHigh + 1
Else
Minimum = HighOrLow
NoE = LowOrHigh - HighOrLow + 1
End If
' Write the unique random list of numbers to the Numbers Dictionary.
Dim Current As Long
Do
Randomize ' Takes considerably longer.
Current = Int(Minimum + NoE * Rnd)
dict(Current) = Empty
Loop Until dict.Count = NoE
' Write the result.
RandomDictionaryToArray = dict.Keys
End Function
Generate 50 random numbers, write them to the cell, and calculate the ranks so that duplicate items do not occur.
Sub Button3_Click()
Dim FillRange As Range, c As Range
Dim rng As Range
Dim vR(1 To 50), a(1 To 50)
Dim vDB
Dim i As Integer, j As Integer
Dim n As Integer
Set FillRange = Range("A1:A10")
For i = 1 To 50
vR(i) = Rnd
Next i
'write random number to the cell
Set rng = Range("i1").Resize(1, 50)
rng = vR
'calcuclate the ranks
For i = 1 To 50
a(i) = WorksheetFunction.Rank(vR(i), rng)
Next
Set FillRange = Range("A1:e10")
vDB = FillRange
For i = 1 To UBound(vDB, 1)
For j = 1 To UBound(vDB, 2)
n = n + 1
vDB(i, j) = a(n)
Next j
Next i
FillRange = vDB
End Sub
Here's code that assigns the cells to the numbers in random order. You can change the size of the matrix.
Private Sub CmdFill_Click()
' 186
Dim Rng As Range ' target range
Dim C As Long ' random column
Dim R As Long ' random row
Dim Tmp As Variant ' random address
Dim Spike As String ' used addresses
Dim n As Integer ' loop counter: 1 to 50
Set Rng = Range("A1:E10") ' change to suit
Randomize
With Rng
.ClearContents
For n = 1 To .Cells.Count
If n < (.Cells.Count - 2) Then
Do
R = Int((.Rows.Count - 1 + 1) * Rnd + 1)
C = Int((.Columns.Count - 1 + 1) * Rnd + 1)
Tmp = Cells(R, C).Address(0, 0)
Loop While InStr(Spike, Tmp)
Range(Tmp).Value = n
Spike = Spike & Tmp & ","
Else
' select the last 3 by availability
Tmp = .Value
For R = 10 To 1 Step -1
For C = 1 To 5
If IsEmpty(Tmp(R, C)) Then
Cells(R, C).Value = n
R = 1
Exit For
End If
Next C
Next R
End If
Next n
End With
End Sub
I've programmed it so that you can change the size of the matrix (when you define the range at the top of the code) but it must start in A1. Starting in another cell will require a little modification.
The code will find unused cells at random. Toward the end this becomes time consuming. Therefore I stopped the process for the last 3 numbers. For them the code just looks for remaining blank cells and assigns the numbers to them. You can change the number of cells filled in that way.
I made a version where you pull random items from the collection of 50 unique numbers:
Sub test()
Dim maxNum As Long: maxNum = 50
Dim nums As Collection
Set nums = FillCollection(maxNum) 'Fill our collection with all nums to be used
Dim count As Long
For count = 1 To maxNum
'Place a random item from our collection into the next cell
Sheet1.Cells(count, 1).Value = PullRandObjFromCollection(nums)
Next count
End Sub
Function FillCollection(ByVal maxNum As Long) As Collection
Set FillCollection = New Collection
Dim count As Long
For count = 1 To maxNum
FillCollection.Add count, CStr(count)
Next count
End Function
Function PullRandObjFromCollection(ByRef coll As Collection) As Variant
Dim randNum As Double
randNum = WorksheetFunction.RandBetween(1, coll.count)
PullRandObjFromCollection = coll.Item(randNum)
coll.Remove randNum 'this function permanently alters the Collection
End Function