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.

 

[Peter_SSs]

Existing values in B2:B16 will not repeat.

.. on the second run ... but could repeat on or after the third run.

 

[kvsrinivasamurthy]

Doest till all numbers are exhausted there should not be repeation.

 

[Peter_SSs]

Doest till all numbers are exhausted there should not be repeation.

Then I don't think that you have tested that very well.
There is nothing in your code that records what was picked the time before last or any time before that.
This is how I tested your code.
I set up the sheet like below. Numbers in column A down to row 5001. Formula in D2 copied down to row 5001. This formula records if any of the 5,000 numbers is entered in B2:B16

I added the line shown right near the end of your code as well as the extra procedure shown at the bottom. Each time the code is run it copies the values from column D and adds them to any existing numbers in column E, thereby giving an updated count of how many times the numbers in column A have been chosen. If numbers are not repeated, the formula in E1 should not exceed 1.

Alfaze.xlsm
	A	B	C	D	E
1					0
2	1			0
3	2			0
4	3			0
5	4			0
6	5			0
7	6			0
8	7			0
9	8			0
10	9			0
11	10			0
12	11			0
13	12			0
14	13			0
15	14			0
16	15			0
17	16			0
18	17			0
19	18			0
20	19			0
Test

Cell Formulas
Range	Formula
E1	E1	=MAX(E2:E5000)
D2:D20	D2	=--ISNUMBER(MATCH(A2,B$2:B$16,0))

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
UpdateCount Range("D2:D5001") '**********************************************************
End Sub

Sub UpdateCount(r As Range)
  With r
    .Copy
    .Offset(, 1).PasteSpecial Paste:=xlValues, Operation:=xlAdd
  End With
  Application.CutCopyMode = False
End Sub

Here is the sheet again after I have run the code 7 times. Cell E1 shows that at least one number has been selected twice in those 7 runs (happened to be the number 3004 in this test)
I have cleared E2:E5002 and repeated the test several times. On one occasion a number doubled up after only 3 runs but mostly it happened between about 7 to 15 runs - but certainly well before all 5000 numbers were used once.

Alfaze.xlsm
	A	B	C	D	E
1					2
2	1	3872		0	0
3	2	4197		0	0
4	3	4506		0	0
5	4	4000		0	0
6	5	1738		0	0
7	6	3004		0	0
8	7	2625		0	0
9	8	4462		0	0
10	9	971		0	0
11	10	521		0	0
12	11	2813		0	0
13	12	1198		0	0
14	13	28		0	1
15	14	1106		0	0
16	15	4949		0	0
17	16			0	0
18	17			0	0
19	18			0	0
20	19			0	1
Test

Cell Formulas
Range	Formula
E1	E1	=MAX(E2:E5000)
D2:D20	D2	=--ISNUMBER(MATCH(A2,B$2:B$16,0))

 

[kvsrinivasamurthy]

This code does not repeat any number till all numbers are exhausted.
Helper column Z is used. If it not free in your file change it some other free column. Change "Z" in all lines in the code.

Sub GetRandomNumbers()
Dim T&, Ta&, K&, Alr, Lr&, Lr2&, A, B
Dim RstRng As Range
Alr = Range("A" & Rows.Count).End(xlUp).Row
A = Range("A2:A" & Alr)
Set RstRng = Range("B2:B16")
Range("Z1") = "Helper Column"

Lr = Range("Z" & Rows.Count).End(xlUp).Offset(1, 0).Row
Lr2 = Lr - 1
With CreateObject("Scripting.Dictionary")
For T = 1 To 15
Line1:
K = 0
K = WorksheetFunction.RandBetween(1, Alr - 1)
If Not .exists(K) And WorksheetFunction.CountIf(Range("Z2:Z" & Lr), A(K, 1)) = 0 Then
.Add K, A(K, 1): Range("Z" & Lr) = A(K, 1)
    If Lr - 1 = UBound(A, 1) Then
    Range("Z2:Z" & Lr2).Delete (xlUp)
    Lr = Range("Z" & Rows.Count).End(xlUp).Row
    End If
Lr = Lr + 1
Else
GoTo Line1
End If
Next T
RstRng.Clear
RstRng.Value = Application.WorksheetFunction.Transpose(.items)

End With
End Sub

 

[Alfaze]

This code does not repeat any number till all numbers are exhausted.
Helper column Z is used. If it not free in your file change it some other free column. Change "Z" in all lines in the code.

Sub GetRandomNumbers()
Dim T&, Ta&, K&, Alr, Lr&, Lr2&, A, B
Dim RstRng As Range
Alr = Range("A" & Rows.Count).End(xlUp).Row
A = Range("A2:A" & Alr)
Set RstRng = Range("B2:B16")
Range("Z1") = "Helper Column"

Lr = Range("Z" & Rows.Count).End(xlUp).Offset(1, 0).Row
Lr2 = Lr - 1
With CreateObject("Scripting.Dictionary")
For T = 1 To 15
Line1:
K = 0
K = WorksheetFunction.RandBetween(1, Alr - 1)
If Not .exists(K) And WorksheetFunction.CountIf(Range("Z2:Z" & Lr), A(K, 1)) = 0 Then
.Add K, A(K, 1): Range("Z" & Lr) = A(K, 1)
    If Lr - 1 = UBound(A, 1) Then
    Range("Z2:Z" & Lr2).Delete (xlUp)
    Lr = Range("Z" & Rows.Count).End(xlUp).Row
    End If
Lr = Lr + 1
Else
GoTo Line1
End If
Next T
RstRng.Clear
RstRng.Value = Application.WorksheetFunction.Transpose(.items)

End With
End Sub

Thanks, that is perfect

 

[Peter_SSs]

Thanks, that is perfect

Great news.
Just wondering though: Did the post 9 code fail for you in some way?

 

[Alfaze]

I didn't try it, post 10 just looked a bit simpler so I went with that!

 

[Peter_SSs]

I didn't try it, post 10 just looked a bit simpler so I went with that!

Fair enough. Doesn't encourage people to help next time if you don't even try suggestions though.