Macro to select cells in a range randomly without repeating?

musicgold

Board Regular
Joined
Jan 9, 2008
Messages
175
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
 

Jeffrey Mahoney

Well-known Member
Joined
May 31, 2015
Messages
1,591
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
 

JoeMo

MrExcel MVP
Joined
May 26, 2009
Messages
16,645
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:

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
41,774
Office Version
365
Platform
Windows
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
 

Rick Rothstein

MrExcel MVP
Joined
Apr 18, 2011
Messages
35,416
Office Version
2010
Platform
Windows
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
 

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
7,417
Office Version
2016
Platform
Windows
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
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
41,774
Office Version
365
Platform
Windows
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:

Rick Rothstein

MrExcel MVP
Joined
Apr 18, 2011
Messages
35,416
Office Version
2010
Platform
Windows
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.
 

Forum statistics

Threads
1,078,068
Messages
5,338,018
Members
399,195
Latest member
cmdv

Some videos you may like

This Week's Hot Topics

Top