Macro to select cells in a range randomly without repeating?

musicgold

Board Regular
Joined
Jan 9, 2008
Messages
197
Hi,

I have a range of 100 cells consisting of numbers, arranged in a 10x10 format. I need to randomly choose one cell and remove the number in it from the pool. I have to keep repeating the process until all 100 numbers have been selected. In other words, I can't select a cell twice and the pool shrinks after each selection.

How can I create a macro to do this process in the most efficient manner?

Thanks
 

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
Am I to assume that you need to have it select a cell and wait for you to have it select another?
 
Upvote 0
Ok, so this may need to be tweaked a little for you needs. The SUB StartNewFind resets all the values and finds the first random cell. The Sub ContinueFind leaves the values and finds the next random cell. The Sub FindRandCell does all the work, making sure to not find a duplicate. The Cell coloring part of the code between the lines is only for showing the cells selected, you can remove that. If all you want to do is display the cell contents in a messagebox, then add that code in place of the code that says: R(X).Select.

Ask me any questions

VBA Code:
Sub StartNewFind()
  Call FindRandCell(True)
End Sub

Sub ContinueFind()
  Call FindRandCell(False)
End Sub


Static Sub FindRandCell(NewSearch As Boolean)
  Static R() As Range
  Static Prev As String
  Static Cnt As Long
  Dim Cel As Range
  Dim X As Long
  Dim A As String
  Dim Test As Boolean

  On Error Resume Next
  Test = IsObject(R(1))
  On Error GoTo 0
 
  If NewSearch = True Or Test = False Then
    ReDim R(100)
    Cnt = 0
    X = 0
    Prev = ""
    
    For Each Cel In Range("A1:J10")
      X = X + 1
      Set R(X) = Cel
    Next Cel
    
  End If
  If Cnt > 99 Then Exit Sub
 
  Do
    X = Application.WorksheetFunction.RandBetween(1, 100)
    A = Format(X, "000")
    If InStr(Prev, A) = 0 Then
      Prev = Prev & ", " & A
      Cnt = Cnt + 1
      R(X).Select
      '-----------------------------------------
      With R(X).Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent4
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
      End With
      '------------------------------------------
      Exit Do
    End If
  Loop
 
End Sub
 
Upvote 0
Try this:
VBA Code:
Sub RandPickAndRemove()
'Select a 10x10 matrix of cells then run this macro
Dim R As Range, c As Range, d As Object, Rw As Long, Col As Long
Set R = Selection
If R.Count <> 100 Or Application.CountA(R) <> 100 Then
    MsgBox "Selection must be a 10x10 range with no empty cells - try again"
    Exit Sub
End If
Set d = CreateObject("Scripting.dictionary")
Do While d.Count < 100
    x = Application.RandBetween(1, 10)
    y = Application.RandBetween(1, 10)
    If R.Cells(x, y) <> "" Then
        If Not d.exists(x & "|" & y) Then
            d.Add x & "|" & y, d.Count + 1
            MsgBox "The number " & R.Cells(x, y).Value & " has been removed"
            R.Cells(x, y).ClearContents
        End If
    End If
Loop
MsgBox "All " & d.Count & " numbers have been removed from the selection"
End Sub
 
Last edited:
Upvote 0
Another option. This will also work for any size (rectangular) range just by changing the line: With Range("A1:J10")

I have assumed that the numbers in the range are all unique and for the moment that they are also all integers.

VBA Code:
Sub Random_Picks()
  Dim d As Object
  Dim r As Long, c As Long, tmp As Long

  Set d = CreateObject("Scripting.Dictionary")
  Randomize
  With Range("A1:J10")
    For r = 1 To .Rows.Count
      For c = 1 To .Columns.Count
        d(.Cells(r, c).Value) = 1
      Next c
    Next r
    Do Until d.Count = 0
      tmp = d.keys()(Int(Rnd() * d.Count))
      .Find(What:=tmp, LookAt:=xlWhole).Select
      Selection.Interior.Color = vbRed
      MsgBox "Next number: " & tmp
      Selection.Clear
      d.Remove (tmp)
    Loop
  End With
End Sub
 
Upvote 0
Here is another macro that you can consider which works with any size grid (just change the A1:J10 in the Set statement) and it works with any content in the cells as well....
VBA Code:
Sub RandomRemoval()
  Dim X As Long, Rng As Range
  Randomize
  Set Rng = Range("A1:J10")
  For X = 1 To Rng.Count
    Rng.Find("?*", Cells(Int(Rng.Rows.Count * Rnd + Rng(1).Row), Int(Rng.Columns.Count * Rnd + Rng(1).Column)), , xlWhole, , , , , False).Select
    ActiveCell.Interior.Color = vbRed
    MsgBox "Removing """ & ActiveCell.Value & """"
    ActiveCell.Clear
  Next
End Sub
 
Upvote 0
Or maybe this :
VBA Code:
Sub Test()

    Const TARGET_RANGE_ADDRESS As String = "Sheet1!A1:J100" '<== change target range as required.
    
    Dim lRndNum As Long, lCellsCount As Long, lCounter As Long
    Dim arBitSet() As Byte, oRange As Range
    
    Set oRange = Range(TARGET_RANGE_ADDRESS)
    lCellsCount = oRange.Cells.Count
    ReDim arBitSet(lCellsCount)
    
    For lCounter = 1 To lCellsCount
        Do
            Randomize
            lRndNum = Int(Rnd * lCellsCount) + 1
            If arBitSet(lRndNum) = 0 Then
                oRange.Cells(lRndNum).ClearContents
                arBitSet(lRndNum) = 1
                Exit Do
            End If
            
        Loop
    Next lCounter

End Sub
 
Upvote 0
Here is another macro that you can consider which works with any size grid (just change the A1:J10 in the Set statement) and it works with any content in the cells as well....
Good idea. (y)
One shortening suggested change
Rich (BB code):
Rng.Find("?*", Cells(Int(Rng.Rows.Count * Rnd + Rng(1).Row), Int(Rng.Columns.Count * Rnd + Rng(1).Column)), , xlWhole, , , , , False).Select
Rng.Find("?*", Rng(1 + Int(Rnd * Rng.Count)), , , , , , , False).Select
 
Last edited:
Upvote 0
Good idea. (y)
One shortening suggested change
Rich (BB code):
Rng.Find("?*", Cells(Int(Rng.Rows.Count * Rnd + Rng(1).Row), Int(Rng.Columns.Count * Rnd + Rng(1).Column)), , xlWhole, , , , , False).Select
Rng.Find("?*", Rng(1 + Int(Rnd * Rng.Count)), , , , , , , False).Select
Good idea back at you! (y) I originally was going to code it differently and got the idea to do it the way I posted midway through the coding... I then tore what I had written apart and wrote what I posted... I just never went back to see if I could tighten things up any.
 
Upvote 0

Forum statistics

Threads
1,213,515
Messages
6,114,080
Members
448,548
Latest member
harryls

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