Randomize where a random number is limited to the number of repeats

[brianfosterblack]

I have this code to select a random number up to the value I enter in Cell A1
In Cell B1 I enter the number of rows I want to fill.
This VBA ensures that each number is only selected once
The problem I have is that sometimes Cell B1 is a larger number than cell B2 so I want to be able to enter in cell C1 (or enter a formula) the maximum number of times a number can be repeated
so if the maximum number I want is 10 but I want to fill 20 rows, then in cell C1 I will enter 2 which means the numbers 1 to 10 can be repeated twice.
Is there any way of adjusting this code to allow this.

Option Explicit
Option Base 1
Public jj As Long
Sub Resample() ' with the doublesort,numbers randomly found between the range can only appear once
Dim i As Long
Dim hold(10000) As Single, Hold2(10000) As Single

Application.Calculation = xlCalculationManual
Range("NumberRange").ClearContents
Range("A2").Select
Randomize

For i = 1 To Range("A1").Value
Hold2(i) = i
Next i
For jj = 1 To 1
For i = 1 To Range("A1").Value
hold(i) = Rnd
Next i
Call DoubleSort(Range("A1").Value, hold, Hold2)
For i = 1 To Range("B1").Value
ActiveCell.Offset(1, 0).Select
ActiveCell = Hold2(i)
Next i
Next jj
Application.Calculation = xlCalculationAutomatic
Range("A1").Select
End Sub

'***********************************************************************
'* Sorting Process - Sort array y based on array x *
'***********************************************************************

Sub DoubleSort(n As Long, x() As Single, y() As Single)
Dim xTemp As Double
Dim yTemp As Double
Dim i As Long
Dim j As Long

For j = 2 To n
xTemp = x(j)
yTemp = y(j)
For i = j - 1 To 1 Step -1
If (x(i) <= xTemp) Then GoTo 10
x(i + 1) = x(i)
y(i + 1) = y(i)
Next i
i = 0
10 x(i + 1) = xTemp
y(i + 1) = yTemp
Next j

End Sub

 

[jasonb75]

Not sure why it is getting stuck on that line, I've tried various values in A1 and B1 with no issues.

Looking at Rick's question in post 9, I suspect that he has something better in mind which is beyond my capabilities.

 

[Rick Rothstein]

Give the following macro (RandomNumbersWithRepeatConstrol) a try. Note that there is a function that the macros calls twice, so make sure you copy both code procedures into your code module.

Sub RandomNumbersWithRepeatConstrol()
  Dim cnt As Long, RandomIndex As Long, Tmp As Variant, Nums As Variant
  If [A1*C1<B1] Then
    MsgBox "Too many cells specified for the given repeat control!"
  Else
    Nums = RandomizeArray(Evaluate("TRANSPOSE(ROW(1:" & [A1] & "))"))
    Nums = Split(Trim(Application.Rept(Join(Nums) & " ", [C1])))
    ReDim Preserve Nums(0 To [B1])
    Nums = RandomizeArray(Nums)
    Range("D1").Resize([B1]) = Application.Transpose(Nums)
  End If
End Sub

Function RandomizeArray(ArrayIn As Variant)
  Dim cnt As Long, RandomIndex As Long, Tmp As Variant
  For cnt = UBound(ArrayIn) To LBound(ArrayIn) Step -1
    RandomIndex = Int((cnt - LBound(ArrayIn) + 1) * [RAND()] + LBound(ArrayIn))
    Tmp = ArrayIn(RandomIndex)
    ArrayIn(RandomIndex) = ArrayIn(cnt)
    ArrayIn(cnt) = Tmp
  Next
  RandomizeArray = ArrayIn
End Function

 

[AlphaFrog]

Hi Jason,

No what I do need is for all 10 numbers to be used but they do not all have to be used once before they repeat again. I am keeping the numbers low for this excercise but typically I am working with number ranges from about 35 to 300 and the row numbers vary between 140 and 600
Sometimes I have less rows than numbers in which case the number must only show once and some numbers will be omitted but often the rows are more than the number range but I want to prevent seeing some numbers repeated multiple times and some numbers not being used more than once or at all.
It is a good point you make and what if we do the formula that if we just run the original code for one round of numbers using each number once and then use the formula that if A1/B1 >1 then run the code for the full number of rows equal to A1 and repeat it again by the result of the formula, just starting at the end of the previous range.

The code below calculates the max repeat (based on the max number and number of rows), and uses each number at least the max repeat -1. So if the max repeat is 4, then each number will be used at least three times and some will be used 4 times.

[color=darkblue]Sub[/color] Resample2()
    [color=darkblue]Dim[/color] i [color=darkblue]As[/color] [color=darkblue]Long[/color], j [color=darkblue]As[/color] [color=darkblue]Long[/color], rn [color=darkblue]As[/color] [color=darkblue]Long[/color]
    [color=darkblue]Dim[/color] lMax [color=darkblue]As[/color] [color=darkblue]Long[/color], lCount [color=darkblue]As[/color] [color=darkblue]Long[/color], lRepete [color=darkblue]As[/color] [color=darkblue]Long[/color], cntr [color=darkblue]As[/color] [color=darkblue]Long[/color]
    [color=darkblue]Dim[/color] arr() [color=darkblue]As[/color] Long
    [color=darkblue]Static[/color] bRandomized [color=darkblue]As[/color] [color=darkblue]Boolean[/color]
    
    [color=darkblue]If[/color] [color=darkblue]Not[/color] bRandomized [color=darkblue]Then[/color] Randomize: bRandomized = [color=darkblue]True[/color]
    
    lMax = Range("A1").Value
    lCount = Range("B1").Value
    lRepete = 1 [color=green]'Repete counter[/color]
    
    [color=darkblue]ReDim[/color] arr(1 [color=darkblue]To[/color] lCount)
    [color=darkblue]For[/color] i = 1 [color=darkblue]To[/color] lCount
        [color=green]'Random Number[/color]
        [color=darkblue]Do[/color]
            DoEvents
            rn = Int(lMax * Rnd + 1)
        [color=darkblue]Loop[/color] [color=darkblue]While[/color] Application.Count(Application.Match(arr(), Array(rn), 0)) >= lRepete
        [color=green]'Random Position[/color]
        [color=darkblue]Do[/color]
            DoEvents
            j = Int(lCount * Rnd + 1)
        [color=darkblue]Loop[/color] [color=darkblue]While[/color] arr(j) <> 0
        
        arr(j) = rn
        cntr = cntr + 1
        [color=darkblue]If[/color] cntr = lMax [color=darkblue]Then[/color] cntr = 0: lRepete = lRepete + 1
    [color=darkblue]Next[/color] i
    
    Range("NumberRange").ClearContents
    Range("A3").Resize(lCount).Value = Application.Transpose(arr)
    
[color=darkblue]End[/color] [color=darkblue]Sub[/color]

 

[Rick Rothstein]

The code below calculates the max repeat (based on the max number and number of rows), and uses each number at least the max repeat -1. So if the max repeat is 4, then each number will be used at least three times and some will be used 4 times.

I meant to mention that for my code... what you wrote above applies exactly (as is) to the code I posted in Message #12 .

[COLOR=#00008b].....[/COLOR]
    [COLOR=darkblue]Static[/COLOR] bRandomized [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Boolean[/COLOR]
    
    [COLOR=darkblue]If[/COLOR] [COLOR=darkblue]Not[/COLOR] bRandomized [COLOR=darkblue]Then[/COLOR] Randomize: bRandomized = [COLOR=darkblue]True[/COLOR]
        .....
        rn = Int(lMax * Rnd + 1)
        ....
        [COLOR=darkblue]Do[/COLOR]
            DoEvents
            j = Int(lCount * Rnd + 1)
        [COLOR=darkblue]Loop[/COLOR] [COLOR=darkblue]While[/COLOR] arr(j) <> 0
        ....
[COLOR=darkblue][/COLOR]

If you replace the two calls to the Rnd function with [RAND()], then you will tap into Excel's much better randomizer while at the same time eliminating the need for your bRandomize flag and call out to VB's Randomize function.