How to get random generator to pick from a list but delete the item it has picked

[Alfaze]

Trying to get a list of 15 numbers randomly picked from a list of around 5000 for regular random stock counts, but once picked I don't want them to come up again. Any way to write the formula for this?

Currently I have a random generator set up using RANDBETWEEN function, but the issue is sometimes the same numbers come up again, unless i manually delete them out.

 

[kvsrinivasamurthy]

Input numbers range is A2:A5001
Result range B2:B16

Sub GetRandomNumbers()
Dim T&, K&, A

A = Range("A2:A5001")
With CreateObject("Scripting.Dictionary")
For T = 1 To 15
Line1:
K = 0
K = WorksheetFunction.RandBetween(1, 5000)
If Not .exists(K) Then
.Add K, A(K, 1)
Else
GoTo Line1
End If
Next T
Range("B2").Resize(15, 1) = Application.WorksheetFunction.Transpose(.items)

End With
End Sub

 

[Alfaze]

Sorry, I am a bit thick and don't know how to use VBA.

https://ruksterlinggp.sharepoint.co...5IgB8bpH4TLo8BYW9PmuCLDf3AklrkDFKmSw?e=W3a2dj
Please see attached file which I am using, I want it to run off the button selecting items from the list on the other sheet.

 

[Peter_SSs]

Trying to get a list of 15 numbers randomly picked from a list of around 5000 for regular random stock counts, but once picked I don't want them to come up again. Any way to write the formula for this?

Welcome to the MrExcel board!

Try this formula. Change the 5,000 and/or the 15 as you require

=LET(n,5000,TAKE(SORTBY(SEQUENCE(n),RANDARRAY(n)),15))

 

[kvsrinivasamurthy]

How to use (VBA) Macro code

To paste the code
In the developer tab click--> Visual Basic
VB window opens
Insert--> Module
Paste the code.
Close the VB window.
Save file as .xlsm

select Developer tab
macros
Select the macro "GetRandomNumbers"
Run

 

[Alfaze]

How to use (VBA) Macro code

To paste the code
In the developer tab click--> Visual Basic
VB window opens
Insert--> Module
Paste the code.
Close the VB window.
Save file as .xlsm

select Developer tab
macros
Select the macro "GetRandomNumbers"
Run

Thanks, I have now managed to make this work, however how do i check that it is not going to repeat a number more than once?

 

[kvsrinivasamurthy]

Your result is in range A1:A15.
In B1 apply this formula and copy it down to B15. B column shows the count of A column value. It should be 1.

=Countif($A$1:$A$15,A1)

 

[Alfaze]

Your result is in range A1:A15.
In B1 apply this formula and copy it down to B15. B column shows the count of A column value. It should be 1.

=Countif($A$1:$A$15,A1)

I get that, however as soon as run the code again it could pick a number that was picked when it was previously run, which I don't want it to do. How do I stop this from happening?

 

[Peter_SSs]

as soon as run the code again

It wasn't clear in post 1 that the process was to be repeated.
How many times will it be repeated? If you keep repeating the process and eliminating the numbers you will eventually run out of numbers to choose from.

Also, in post 1, you asked for a formula.

Anyway, give this a try. It uses column A as a source of values (but the code populates that column itself so you don't have to) and puts the random values in column B
It will not repeat any numbers until all the column A values have been used or at least until there are not enough numbers left in column A to choose from when the code will automatically replenish the col A numbers.
In the 'Const' lines in the code put how many values you want to choose from (5,000 as mentioned in post 1) and how many you want to choose each time the code is run (15 in your example)

Sub Pick_Random()
  Dim d As Object
  Dim a As Variant, b As Variant
  Dim i As Long, k As Long, n As Long
 
  Const ChooseFrom As Long = 5000 '<- Change as wanted
  Const HowMany As Long = 15      '<- Change as wanted
 
  Set d = CreateObject("Scripting.Dictionary")
  ReDim b(1 To HowMany, 1 To 1)
  Randomize
  Application.ScreenUpdating = False
  With Range("A1:A" & ChooseFrom)
    If Application.Count(Range(.Address)) < HowMany Then .Value = Evaluate("row(" & .Address & ")")
    a = .Value
    For i = 1 To ChooseFrom
      If Len(a(i, 1)) > 0 Then d(i) = 1
    Next i
    For i = 1 To HowMany
      n = 1 + Int(Rnd() * d.Count)
      k = k + 1
      b(k, 1) = d.keys()(n - 1)
      d.Remove b(k, 1)
      a(b(k, 1), 1) = Empty
    Next i
    .Value = a
  End With
  Range("B1", Range("B" & Rows.Count).End(xlUp)).ClearContents
  Range("B1").Resize(HowMany).Value = b
  Application.ScreenUpdating = True
End Sub

 

[kvsrinivasamurthy]

Try. Existing values in B2:B16 will not repeat.

Sub GetRandomNumbers()
Dim T&, Ta&, K&, A, B
Dim RstRng As Range
A = Range("A2:A5001")
Set RstRng = Range("B2:B16")

With CreateObject("Scripting.Dictionary")
For T = 1 To 15
Line1:
K = 0
K = WorksheetFunction.RandBetween(1, 5000)
If Not .exists(K) And WorksheetFunction.CountIf(RstRng, A(K, 1)) = 0 Then
.Add K, A(K, 1)
Else
GoTo Line1
End If
Next T
RstRng.Clear
RstRng.Value = Application.WorksheetFunction.Transpose(.items)

End With
End Sub