Extracting number from a range randomly

Goalexcel

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.
 
Sort by date Sort by votes
Can you click on cell A21, and press Ctrl + Down Arrow? do you have some data down the sheet?
 
Upvote 0

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.
My code would be this

I am assuming that the headers for the results exist (like row 20 in your sample sheets) but nothing below that before the first run of the code.

VBA Code: 
Sub Pick_N_v2()
  Dim d As Object
  Dim a As Variant, b As Variant, Results As Variant
  Dim c As Long, i As Long, k As Long, ShNum As Long, PicksMade As Long, NumsLeft As Long
  Dim PickHowMany As Long, Rws As Long, Cols As Long, NextClr As Long, ResultsHeaderRow As Long
  
  Randomize
  Set d = CreateObject("Scripting.Dictionary")
  For ShNum = 1 To 5
    With Sheets(ShNum)
      Application.Goto Reference:=.Range("A1"), Scroll:=True
      Rws = .Range("A1").End(xlDown).Row - 1
      Cols = .Cells(1, Columns.Count).End(xlToLeft).Column
      ResultsHeaderRow = .Range("A1").End(xlDown).End(xlDown).Row
      PicksMade = .Range("A" & ResultsHeaderRow).CurrentRegion.Rows.Count - 1
      If PicksMade > 0 Then
        b = .Range("A" & ResultsHeaderRow + 1).Resize(PicksMade, Cols).Value
        NextClr = .Range("A" & Rows.Count).End(xlUp).Interior.ColorIndex + 2
      Else
        NextClr = 4
      End If
      NumsLeft = Rws - PicksMade
      Do
        PickHowMany = Application.InputBox("Pick how many numbers? (Max = " & NumsLeft & ")", .Name, IIf(NumsLeft > 3, 3, NumsLeft), , , , , 1)
      Loop Until PickHowMany <= NumsLeft
      If PickHowMany > 0 Then
        With .Range("A2").Resize(Rws, Cols)
          a = .Value
          ReDim Results(1 To PickHowMany, 1 To Cols)
          For c = 1 To UBound(a, 2)
            d.RemoveAll
            For i = 1 To Rws
              d(a(i, c)) = i
            Next i
            If PicksMade > 0 Then
              For i = 1 To PicksMade
                d.Remove b(i, c)
              Next i
            End If
            For i = 1 To PickHowMany
              k = 1 + Int(Rnd() * d.Count)
              Results(i, c) = d.Keys()(k - 1)
              .Cells(d.Items()(k - 1), c).Interior.ColorIndex = NextClr
              d.Remove Results(i, c)
            Next i
          Next c
        End With
        With .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(PickHowMany, UBound(Results, 2))
          .Select
          .Value = Results
          .Interior.ColorIndex = NextClr
        End With
      Else
        MsgBox "Zero picks chosen. Sheet '" & .Name & "' has been skipped"
      End If
    End With
  Next ShNum
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
Peter_SSs said:
My code would be this

I am assuming that the headers for the results exist (like row 20 in your sample sheets) but nothing below that before the first run of the code.

VBA Code: 
Sub Pick_N_v2()
  Dim d As Object
  Dim a As Variant, b As Variant, Results As Variant
  Dim c As Long, i As Long, k As Long, ShNum As Long, PicksMade As Long, NumsLeft As Long
  Dim PickHowMany As Long, Rws As Long, Cols As Long, NextClr As Long, ResultsHeaderRow As Long
 
  Randomize
  Set d = CreateObject("Scripting.Dictionary")
  For ShNum = 1 To 5
    With Sheets(ShNum)
      Application.Goto Reference:=.Range("A1"), Scroll:=True
      Rws = .Range("A1").End(xlDown).Row - 1
      Cols = .Cells(1, Columns.Count).End(xlToLeft).Column
      ResultsHeaderRow = .Range("A1").End(xlDown).End(xlDown).Row
      PicksMade = .Range("A" & ResultsHeaderRow).CurrentRegion.Rows.Count - 1
      If PicksMade > 0 Then
        b = .Range("A" & ResultsHeaderRow + 1).Resize(PicksMade, Cols).Value
        NextClr = .Range("A" & Rows.Count).End(xlUp).Interior.ColorIndex + 2
      Else
        NextClr = 4
      End If
      NumsLeft = Rws - PicksMade
      Do
        PickHowMany = Application.InputBox("Pick how many numbers? (Max = " & NumsLeft & ")", .Name, IIf(NumsLeft > 3, 3, NumsLeft), , , , , 1)
      Loop Until PickHowMany <= NumsLeft
      If PickHowMany > 0 Then
        With .Range("A2").Resize(Rws, Cols)
          a = .Value
          ReDim Results(1 To PickHowMany, 1 To Cols)
          For c = 1 To UBound(a, 2)
            d.RemoveAll
            For i = 1 To Rws
              d(a(i, c)) = i
            Next i
            If PicksMade > 0 Then
              For i = 1 To PicksMade
                d.Remove b(i, c)
              Next i
            End If
            For i = 1 To PickHowMany
              k = 1 + Int(Rnd() * d.Count)
              Results(i, c) = d.Keys()(k - 1)
              .Cells(d.Items()(k - 1), c).Interior.ColorIndex = NextClr
              d.Remove Results(i, c)
            Next i
          Next c
        End With
        With .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(PickHowMany, UBound(Results, 2))
          .Select
          .Value = Results
          .Interior.ColorIndex = NextClr
        End With
      Else
        MsgBox "Zero picks chosen. Sheet '" & .Name & "' has been skipped"
      End If
    End With
  Next ShNum
  Application.ScreenUpdating = True
End Sub
Click to expand...
Thank you Mr.Peter, outstanding support. The excel automation process is improving the quality service.
 
Upvote 0
Peter_SSs said:
My code would be this

I am assuming that the headers for the results exist (like row 20 in your sample sheets) but nothing below that before the first run of the code.

VBA Code: 
Sub Pick_N_v2()
  Dim d As Object
  Dim a As Variant, b As Variant, Results As Variant
  Dim c As Long, i As Long, k As Long, ShNum As Long, PicksMade As Long, NumsLeft As Long
  Dim PickHowMany As Long, Rws As Long, Cols As Long, NextClr As Long, ResultsHeaderRow As Long
 
  Randomize
  Set d = CreateObject("Scripting.Dictionary")
  For ShNum = 1 To 5
    With Sheets(ShNum)
      Application.Goto Reference:=.Range("A1"), Scroll:=True
      Rws = .Range("A1").End(xlDown).Row - 1
      Cols = .Cells(1, Columns.Count).End(xlToLeft).Column
      ResultsHeaderRow = .Range("A1").End(xlDown).End(xlDown).Row
      PicksMade = .Range("A" & ResultsHeaderRow).CurrentRegion.Rows.Count - 1
      If PicksMade > 0 Then
        b = .Range("A" & ResultsHeaderRow + 1).Resize(PicksMade, Cols).Value
        NextClr = .Range("A" & Rows.Count).End(xlUp).Interior.ColorIndex + 2
      Else
        NextClr = 4
      End If
      NumsLeft = Rws - PicksMade
      Do
        PickHowMany = Application.InputBox("Pick how many numbers? (Max = " & NumsLeft & ")", .Name, IIf(NumsLeft > 3, 3, NumsLeft), , , , , 1)
      Loop Until PickHowMany <= NumsLeft
      If PickHowMany > 0 Then
        With .Range("A2").Resize(Rws, Cols)
          a = .Value
          ReDim Results(1 To PickHowMany, 1 To Cols)
          For c = 1 To UBound(a, 2)
            d.RemoveAll
            For i = 1 To Rws
              d(a(i, c)) = i
            Next i
            If PicksMade > 0 Then
              For i = 1 To PicksMade
                d.Remove b(i, c)
              Next i
            End If
            For i = 1 To PickHowMany
              k = 1 + Int(Rnd() * d.Count)
              Results(i, c) = d.Keys()(k - 1)
              .Cells(d.Items()(k - 1), c).Interior.ColorIndex = NextClr
              d.Remove Results(i, c)
            Next i
          Next c
        End With
        With .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(PickHowMany, UBound(Results, 2))
          .Select
          .Value = Results
          .Interior.ColorIndex = NextClr
        End With
      Else
        MsgBox "Zero picks chosen. Sheet '" & .Name & "' has been skipped"
      End If
    End With
  Next ShNum
  Application.ScreenUpdating = True
End Sub
Click to expand...
Hello @Peter_SSs , thank you in advance to anyone can help.

I have to modify the way to choose random number. What we need is to choose continuous numbers, when pop up message: PickHow many number, I will enter 4,
and the code need to choose 4 continues number in all the columns.
1637120212101.png
 
Upvote 0
Goalexcel said:
I have to modify the way to choose random number. What we need is to choose continuous numbers, when pop up message: PickHow many number, I will enter 4,
and the code need to choose 4 continues number in all the columns.
Click to expand...
If this is related to the original question I don't see how that would work. Previously, we kept picking until all numbers in the column were used. In your example image, in column D, if those yellow cells were picked first, how would the first two numbers in cells D2 and D3 ever get picked since they can now never be pert of "4 continuous numbers"
 
Upvote 0
Peter_SSs said:
If this is related to the original question I don't see how that would work. Previously, we kept picking until all numbers in the column were used. In your example image, in column D, if those yellow cells were picked first, how would the first two numbers in cells D2 and D3 ever get picked since they can now never be pert of "4 continuous numbers"
Click to expand...
Hello @Peter_SSs , thank you for your replay. You totally right, Let me rectify:

1. Choose continuous 4 numbers from the beginning row A1 all columns., count all columns until end
Copy in row A21 for all columns.

2. Use the code in sheet1 until sheet8, count all sheet until end.
 
Upvote 0
As best as I can understand what you want ..

VBA Code: 
Sub Pick_N_Consecutive()
  Dim a As Variant, Results As Variant
  Dim c As Long, i As Long, ShNum As Long, StartRow As Long, PickHowMany As Long, Rws As Long, Cols As Long, ResultsHeaderRow As Long
  
  Randomize
  Application.ScreenUpdating = False
  For ShNum = 1 To Sheets.Count
    With Sheets(ShNum)
      Application.Goto Reference:=.Range("A1"), Scroll:=True
      Rws = .Range("A1").End(xlDown).Row - 1
      Cols = .Cells(1, Columns.Count).End(xlToLeft).Column
      ResultsHeaderRow = .Range("A1").End(xlDown).End(xlDown).Row
      Do
        PickHowMany = Application.InputBox("Pick how many numbers? (Max = " & Rws & ")", .Name, IIf(Rws > 3, 4, Rws), , , , , 1)
      Loop Until PickHowMany <= Rws
      If PickHowMany > 0 Then
        With .Range("A2").Resize(Rws, Cols)
          a = .Value
          ReDim Results(1 To PickHowMany, 1 To Cols)
          For c = 1 To UBound(a, 2)
            StartRow = 1 + Int(Rnd() * (Rws - PickHowMany + 1))
            .Cells(StartRow, c).Resize(PickHowMany).Interior.Color = vbYellow
            For i = 1 To PickHowMany
              Results(i, c) = a(StartRow - 1 + i, c)
            Next i
          Next c
        End With
        With .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(PickHowMany, UBound(Results, 2))
          .Value = Results
          .Interior.Color = vbYellow
        End With
      Else
        MsgBox "Zero picks chosen. Sheet '" & .Name & "' has been skipped"
      End If
    End With
  Next ShNum
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Question Question
Selecting multiple random names from a list, with additional criteria
2
Replies
10
Views
655
Peter_SSs
Peter_SSs
C
  • Question Question
Need help! extract value in special case, find many method, cannot solve it!
Replies
6
Views
177
CLKinfo
C
A
  • Solved
VBA code to extract a table
Replies
5
Views
301
Anthony47
A
A
  • Question Question
Iterate Range
2
Replies
10
Views
258
kvsrinivasamurthy
K
A
  • Solved
Define multiple phone number patterns to one RegEx.
Replies
5
Views
161
JEC
JEC

Forum statistics

Threads
1,224,823
Messages
6,181,185
Members
453,020
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

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