Random Cell Selection Not Working Properly

[FisheriesTech]

Hey Mr.Excel Smarties out there!!

I have an interesting one here for someone smarter then me (which is probably everyone out there!)
I want to select a random subset of cells from a column. I have the below code to do that. It works great except it consistently selects less then the desired 50 cells. What am I doing wrong? Total VBA newbie here.


Option Explicit

Function RandCell(Rg As Range) As Range
Set RandCell = Rg.Cells(Int(Rnd * Rg.Cells.Count) + 1)
End Function

Sub RandomSelection()

Dim Counter2 As Long
Dim TargetRg As Range
Dim Cell As Range

Range("AF2:AF10000").ClearFormats
Range("AF2", Range("AF2").End(xlDown)).Select

Set TargetRg = Selection

For Counter2 = 1 To 50
Set Cell = RandCell(TargetRg)
Cell.Interior.Color = RGB(0, 255, 0)

Next

End Sub




Thank you in advance for anyone who can help. Let me know if you need more information!

 

[FisheriesTech]

Oh man, tried fixing the whole day before posting. Then right after posting it hit me that it was likely selecting values twice at times. Then found this work around from another post here. So sorry for posting again. Maybe someone will find it useful:

Sub RandomSelection2()

Dim Counter2 As Long
Dim TargetRg As Range
Dim Cell As Range

Range("AF2:AF10000").ClearFormats

Range("AF2", Range("AF2").End(xlDown)).Select

Set TargetRg = Selection

With CreateObject("scripting.dictionary")
For Counter2 = 1 To 50
Set Cell = RandCell(TargetRg)
Do Until .Exists(Cell.Address) = False
Set Cell = RandCell(TargetRg)
Loop
.Add Cell.Address, Nothing
Cell.Interior.Color = RGB(0, 255, 0) 'use this if you need one color
Next Counter2
End With
End Sub

 

[BSALV]

old trick

Sub RandomSelection2()
     Set c = Range("AF2", Range("AF2").End(xlDown))             'your selection
     c.ClearFormats                                             'clear formats
     arr = Evaluate("=transpose(row(A1:A" & c.Rows.Count & "))")     'array filled with 1,2,3,..., as many numbers as cells in C
    
     last = UBound(arr)                                         'max number
     For i = 1 To 50                                            'you want 50 unique numbers
          r = Int(Rnd * last) + 1                               'random number between 1st and last
          c.Cells(arr(r)).Interior.ColorIndex = 4               'color that random cell
          arr(r) = arr(last)                                    'move last number to drawn number
          last = last - 1
     Next
End Sub

 

[FisheriesTech]

old trick

Sub RandomSelection2()
     Set c = Range("AF2", Range("AF2").End(xlDown))             'your selection
     c.ClearFormats                                             'clear formats
     arr = Evaluate("=transpose(row(A1:A" & c.Rows.Count & "))")     'array filled with 1,2,3,..., as many numbers as cells in C
   
     last = UBound(arr)                                         'max number
     For i = 1 To 50                                            'you want 50 unique numbers
          r = Int(Rnd * last) + 1                               'random number between 1st and last
          c.Cells(arr(r)).Interior.ColorIndex = 4               'color that random cell
          arr(r) = arr(last)                                    'move last number to drawn number
          last = last - 1
     Next
End Sub

Oh cool. Thank you BSALV. I will try this as well and thank you for providing the explanations for each line. Helps us newbies learn!

 

[BSALV]

you're welcome
a little bit cleaner, with everything inclosed in such a with ... end with

Sub RandomSelection2()
     With Range("AF2", Range("AF2").End(xlDown))                'your selection
          .ClearFormats                                         'clear formats
          arr = Evaluate("=transpose(row(A1:A" & .Rows.Count & "))")     'array filled with 1,2,3,..., as many numbers as cells in C

          last = UBound(arr)                                    'last number = max number
          For i = 1 To 50                                       'you want 50 unique numbers
               r = Int(Rnd * last) + 1                          'random number between 1st and last
               .Cells(arr(r)).Interior.ColorIndex = 4           'color that random cell
               arr(r) = arr(last)                               'move "actual" last number to drawn position
               last = last - 1                                  'new actual last number (move every time 1 position up
          Next
     End With
End Sub