Extracting number from a range randomly

Goalexcel

Board Regular
Joined
Dec 28, 2020
Messages
101
Office Version
  1. 2016
Platform
  1. Windows
Hello Expert, please kindly advise what is the best method to extract numbers from a range randomly
I have a series of numbers in the range of A1 to T16. I would like to extract 3 differents numbers from each columns, and place them in column A21, B21so on. I wonder. if there is a way to do that easily.
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
See if this is what you need.

21 01 14.xlsm
ABCDEFGHIJKLMNOPQRS
149621656877044091579841184940917804129454462912227924576396692028765766779
24879429852003776745579502360223276393966290619429213881701979525777507906
3237730717232875729584894397422649057297546145653375670228789053662914549166
48000925665429430144180862150468461116464615786855026605544673260733444957391
5375280148145463404620277953793717569941848336778125425964172326999592078
6254373387362593203589816276286687659777202142532790103147413732386042317284
7650437386487885370096416361508676255559537294950164726283499587941483619
842532973839326485251317808164588751100050542401690024784228296870761472496
99375143469762129451373411098800096505276173034365150257264683143836770641390
10269354336616289621648548802281121067607487015208744988054065646517155924264
1155907445585377582341552408737047257941794122728309455446552469362414574190
12572376222586416865734573172357759889361963569168295382068207084824569517
1369039384715399633164436862052607506577559974628970022912344343375711970596
14126914361821933169414097535887977261360885942769748458531013210382221656863
15885566531469681901529132149536826399593848717115670560835003248730022973
1668263583270990534635568258968453828354633066719522087058782950523053145074
17
18
19
20
21559054336542212990153457184937048751646495334369700388144672070848214727906
223752938427092593694179503172866750676074184291227906476396417238604567284
234253071585289672952027408753797639396617302272502645544228979532693002496
Extract 3 Random
Cell Formulas
RangeFormula
A21:S23A21=INDEX(A$1:A$16,AGGREGATE(15,6,((ROW(A$1:A$16)-ROW(A$1)+1)/ISNA(MATCH(A$1:A$16,A$20:A20,0))),RANDBETWEEN(1,ROWS(A$1:A$16)-COUNT(A$20:A20))))
 
Upvote 0
VBA solution that can work if some cells contain same info:

VBA Code:
Sub pickRand()
    Dim i As Long, ss As String, r As Long, s As Boolean, c As Long, v
    Randomize
    Application.ScreenUpdating = False
    With ActiveSheet
        For i = 1 To 20 '20 columns = A:T, expand as you wish
            ss = ""
            s = False
            c = 0
            Do
                r = CLng(((Rnd * 1000000) Mod 16)) + 1
                If ss <> "" Then
                    If InStr(ss, CStr(r)) <= 0 Then
                        ss = ss & "," & r
                        s = True
                        c = c + 1
                    End If
                Else
                    ss = r
                    s = True
                    c = c + 1
                End If
            Loop While s = False Or (s = True And c < 3) '3 = number of random cells to pick
            v = Split(ss, ",")
            For c = LBound(v) To UBound(v)
                .Cells(21 + c, i).Value = .Cells(v(c), i).Value '21 = starting row to output selected cells
            Next
        Next
    End With
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
VBA solution that can work if some cells contain same info:

VBA Code:
Sub pickRand()
    Dim i As Long, ss As String, r As Long, s As Boolean, c As Long, v
    Randomize
    Application.ScreenUpdating = False
    With ActiveSheet
        For i = 1 To 20 '20 columns = A:T, expand as you wish
            ss = ""
            s = False
            c = 0
            Do
                r = CLng(((Rnd * 1000000) Mod 16)) + 1
                If ss <> "" Then
                    If InStr(ss, CStr(r)) <= 0 Then
                        ss = ss & "," & r
                        s = True
                        c = c + 1
                    End If
                Else
                    ss = r
                    s = True
                    c = c + 1
                End If
            Loop While s = False Or (s = True And c < 3) '3 = number of random cells to pick
            v = Split(ss, ",")
            For c = LBound(v) To UBound(v)
                .Cells(21 + c, i).Value = .Cells(v(c), i).Value '21 = starting row to output selected cells
            Next
        Next
    End With
    Application.ScreenUpdating = True
End Sub
Thank you very much for your help and support. Can you please, modify the macro, in A1:T I have titles. Also , after choose the random number from the table, need to be checked or color the cells that contained the numbers that had been choosing, in order to control the duplicates every time we do the macro randomly.
RandomNumbersVBA.PNG
 
Upvote 0
See if this is what you need.

21 01 14.xlsm
ABCDEFGHIJKLMNOPQRS
149621656877044091579841184940917804129454462912227924576396692028765766779
24879429852003776745579502360223276393966290619429213881701979525777507906
3237730717232875729584894397422649057297546145653375670228789053662914549166
48000925665429430144180862150468461116464615786855026605544673260733444957391
5375280148145463404620277953793717569941848336778125425964172326999592078
6254373387362593203589816276286687659777202142532790103147413732386042317284
7650437386487885370096416361508676255559537294950164726283499587941483619
842532973839326485251317808164588751100050542401690024784228296870761472496
99375143469762129451373411098800096505276173034365150257264683143836770641390
10269354336616289621648548802281121067607487015208744988054065646517155924264
1155907445585377582341552408737047257941794122728309455446552469362414574190
12572376222586416865734573172357759889361963569168295382068207084824569517
1369039384715399633164436862052607506577559974628970022912344343375711970596
14126914361821933169414097535887977261360885942769748458531013210382221656863
15885566531469681901529132149536826399593848717115670560835003248730022973
1668263583270990534635568258968453828354633066719522087058782950523053145074
17
18
19
20
21559054336542212990153457184937048751646495334369700388144672070848214727906
223752938427092593694179503172866750676074184291227906476396417238604567284
234253071585289672952027408753797639396617302272502645544228979532693002496
Extract 3 Random
Cell Formulas
RangeFormula
A21:S23A21=INDEX(A$1:A$16,AGGREGATE(15,6,((ROW(A$1:A$16)-ROW(A$1)+1)/ISNA(MATCH(A$1:A$16,A$20:A20,0))),RANDBETWEEN(1,ROWS(A$1:A$16)-COUNT(A$20:A20))))
Thank you very much for your help. I've been looking long time , amazing , wow.
 
Upvote 0
VBA Code:
Sub pickRand()
    Dim i As Long, ss As String, r As Long, s As Boolean, c As Long, v
    Randomize
    Application.ScreenUpdating = False
    With ActiveSheet
        .Range("A20:T20").Value = .Range("A1:T1").Value
        For i = 1 To 20 '20 columns = A:T, expand as you wish
            ss = ""
            s = False
            c = 0
            Do
                r = CLng(((Rnd * 1000000) Mod 16)) + 2 ' +2 since you have a header row.
                If ss <> "" Then
                    If InStr(ss, CStr(r)) <= 0 Then
                        ss = ss & "," & r
                        s = True
                        c = c + 1
                    End If
                Else
                    ss = r
                    s = True
                    c = c + 1
                End If
            Loop While s = False Or (s = True And c < 3) '3 = number of random cells to pick
            v = Split(ss, ",")
            For c = LBound(v) To UBound(v)
                .Cells(21 + c, i).Value = .Cells(v(c), i).Value '21 = starting row to output selected cells
                .Cells(v(c), i).Interior.Color = vbYellow
            Next
        Next
    End With
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
VBA Code:
Sub pickRand()
    Dim i As Long, ss As String, r As Long, s As Boolean, c As Long, v
    Randomize
    Application.ScreenUpdating = False
    With ActiveSheet
        .Range("A20:T20").Value = .Range("A1:T1").Value
        For i = 1 To 20 '20 columns = A:T, expand as you wish
            ss = ""
            s = False
            c = 0
            Do
                r = CLng(((Rnd * 1000000) Mod 16)) + 2 ' +2 since you have a header row.
                If ss <> "" Then
                    If InStr(ss, CStr(r)) <= 0 Then
                        ss = ss & "," & r
                        s = True
                        c = c + 1
                    End If
                Else
                    ss = r
                    s = True
                    c = c + 1
                End If
            Loop While s = False Or (s = True And c < 3) '3 = number of random cells to pick
            v = Split(ss, ",")
            For c = LBound(v) To UBound(v)
                .Cells(21 + c, i).Value = .Cells(v(c), i).Value '21 = starting row to output selected cells
                .Cells(v(c), i).Interior.Color = vbYellow
            Next
        Next
    End With
    Application.ScreenUpdating = True
End Sub
Thank you a lot, works perfect, smooth, fast, saving a lot time. Excellent choice. Amazing , wow!!!
 
Upvote 0
Thank you a lot, works perfect
⚡ I beg to differ.
The choices with that code are not truly random. For example if the first number chosen in a column happens to be, say, row 16 in the worksheet then it is then impossible for the number from row 6 in the sheet to also be chosen for that column. The error is with the InStr line in the code.

And another (less important) point:
You will likely never actually notice but the code is also somewhat inefficient in its choosing of the 'next' random value for r since it picks a value and then checks (sometimes incorrectly as I pointed out above) to see if that number has already been chosen. If it has it repeats that process until a suitable random value is chosen. In theory it could get caught up picking an already used value 5 or 10 or 10000 times before choosing a suitable one.

To demonstrate my first point above I altered the suggested code to ensure that row 16 was chosen first in every column as follows
Rich (BB code):
Else
    ss = r
    ss = 16
I then ran the code several times without clearing the yellow colour and this is the result. You see that row 6 has never been chosen

Goalexcel.xlsm
ABCDEFGHIJ
1Sect 1Sect 2Sect 3Sect 4Sect 5Sect 6Sect 7Sect 8Sect 9Sect 10
21101111711331149116511811197121312291245
31102111811341150116611821198121412301246
41103111911351151116711831199121512311247
51104112011361152116811841200121612321248
61105112111371153116911851201121712331249
71106112211381154117011861202121812341250
81107112311391155117111871203121912351251
91108112411401156117211881204122012361252
101109112511411157117311891205122112371253
111110112611421158117411901206122212381254
121111112711431159117511911207122312391255
131112112811441160117611921208122412401256
141113112911451161117711931209122512411257
151114113011461162117811941210122612421258
161115113111471163117911951211122712431259
171116113211481164118011961212122812441260
18
19
20Sect 1Sect 2Sect 3Sect 4Sect 5Sect 6Sect 7Sect 8Sect 9Sect 10
211115113111471163117911951211122712431259
221108112211421158116511901203122512441245
231106113211351156117511911197122112361251
Sheet1


Here is an alternative code that addresses both of the above issues.
It also gives you an easy way to change if you wanted to pick other than 3 numbers from each column.
My code does assume that all the numbers in any single column are different as is the case with your sample.

VBA Code:
Sub Pick_N()
  Dim d As Object
  Dim a As Variant, b As Variant
  Dim c As Long, i As Long, k As Long, uba As Long
 
  Const PickHowMany As Long = 3 '<- Edit to suit
 
  Randomize
  Application.ScreenUpdating = False
  Set d = CreateObject("Scripting.Dictionary")
  With Range("A2:T17")
    a = .Value
    uba = UBound(a)
    ReDim b(1 To PickHowMany, 1 To UBound(a, 2))
    For c = 1 To UBound(a, 2)
      d.RemoveAll
      For i = 1 To uba
        d(a(i, c)) = i
      Next i
      For i = 1 To PickHowMany
        k = 1 + Int(Rnd() * d.Count)
        b(i, c) = d.Keys()(k - 1)
        .Cells(d.Items()(k - 1), c).Interior.Color = vbYellow
        d.Remove b(i, c)
      Next i
    Next c
    Range("A20").Resize(, UBound(a, 2)).Value = .Rows(0).Value
    Range("A21").Resize(UBound(b), UBound(b, 2)).Value = b
  End With
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
The error is with the InStr line in the code.
Great catch, thanks! Initially used dictionary to code it, but thought maybe it wasn't necessary.

Switched back to using dictionary:
VBA Code:
Sub pickRand()
    Dim i As Long, ss As String, r As Long, s As Boolean, c As Long, v, d
    Set d = CreateObject("scripting.dictionary")
    Randomize
    Application.ScreenUpdating = False
    With ActiveSheet
        .Range("A20:T20").Value = .Range("A1:T1").Value
        For i = 1 To 20 '20 columns = A:T, expand as you wish
            d.RemoveAll
            s = False
            c = 0
            Do
                r = CLng(((Rnd * 1000000) Mod 16)) + 2 ' +2 since you have a header row.
                If Not d.exists(r) Then
                    d(r) = 1
                    s = True
                    c = c + 1
                End If
            Loop While s = False Or (s = True And c < 3) '3 = number of random cells to pick
            c = 0
            For Each v In d.keys
                .Cells(21 + c, i).Value = .Cells(CInt(v), i).Value '21 = starting row to output selected cells
                .Cells(CInt(v), i).Interior.Color = vbYellow
                c = c + 1
            Next
        Next
    End With
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
⚡ I beg to differ.
The choices with that code are not truly random. For example if the first number chosen in a column happens to be, say, row 16 in the worksheet then it is then impossible for the number from row 6 in the sheet to also be chosen for that column. The error is with the InStr line in the code.

As another les important point:
You will likely never actually notice but the code is also somewhat inefficient in its choosing of the 'next' random value for r since it picks a value and then checks (sometimes incorrectly as I pointed out above) to see if that number has already been chosen. If it has it repeats that process until a suitable random value is chosen. In theory it could get caught up picking an already used value 5 or 10 or 10000 times before choosing a suitable one.

To demonstrate my first point above I altered the suggested code to ensure that row 16 was chosen first in every column as follows
Rich (BB code):
Else
    ss = r
    ss = 16
I then ran the code several times without clearing the yellow colour and this is the result. You see that row 6 has never been chosen

Goalexcel.xlsm
ABCDEFGHIJ
1Sect 1Sect 2Sect 3Sect 4Sect 5Sect 6Sect 7Sect 8Sect 9Sect 10
21101111711331149116511811197121312291245
31102111811341150116611821198121412301246
41103111911351151116711831199121512311247
51104112011361152116811841200121612321248
61105112111371153116911851201121712331249
71106112211381154117011861202121812341250
81107112311391155117111871203121912351251
91108112411401156117211881204122012361252
101109112511411157117311891205122112371253
111110112611421158117411901206122212381254
121111112711431159117511911207122312391255
131112112811441160117611921208122412401256
141113112911451161117711931209122512411257
151114113011461162117811941210122612421258
161115113111471163117911951211122712431259
171116113211481164118011961212122812441260
18
19
20Sect 1Sect 2Sect 3Sect 4Sect 5Sect 6Sect 7Sect 8Sect 9Sect 10
211115113111471163117911951211122712431259
221108112211421158116511901203122512441245
231106113211351156117511911197122112361251
Sheet1


Here is an alternative code that addresses both of the above issues.
It also gives you an easy way to change if you wanted to pick other than 3 numbers from each column.
My code does assume that all the numbers in any single column are different as is the case with your sample.

VBA Code:
Sub Pick_N()
  Dim d As Object
  Dim a As Variant, b As Variant
  Dim c As Long, i As Long, k As Long, uba As Long

  Const PickHowMany As Long = 3 '<- Edit to suit

  Randomize
  Application.ScreenUpdating = False
  Set d = CreateObject("Scripting.Dictionary")
  With Range("A2:T17")
    a = .Value
    uba = UBound(a)
    ReDim b(1 To PickHowMany, 1 To UBound(a, 2))
    For c = 1 To UBound(a, 2)
      d.RemoveAll
      For i = 1 To uba
        d(a(i, c)) = i
      Next i
      For i = 1 To PickHowMany
        k = 1 + Int(Rnd() * d.Count)
        b(i, c) = d.Keys()(k - 1)
        .Cells(d.Items()(k - 1), c).Interior.Color = vbYellow
        d.Remove b(i, c)
      Next i
    Next c
    Range("A20").Resize(, UBound(a, 2)).Value = .Rows(0).Value
    Range("A21").Resize(UBound(b), UBound(b, 2)).Value = b
  End With
  Application.ScreenUpdating = True
End Sub
Thank you for your replay Mr. Peter. Please check the below link , excel file TestPicknumber
Could you please, check when we pick up numbers by second time, we no need to repeat the numbers. Also workbook have 6 worksheets, so the range is no the same, for that, everytime apply different sheet, result runtime error 9, subscript out of range.
 

Attachments

  • Picknumbers.PNG
    Picknumbers.PNG
    63.2 KB · Views: 57
Last edited:
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,202
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top