Randomly selecting 50 cells from a range & filling with color

[psb1]

hi all,

new to the forum.....I'm currently using a code that needs tweaking:

Function randcell (rg as range) as range
set randcell = rg.cells(int(rnd*rg.cells.count)+1)
end function

sub randcelltest ()
dim counter as long
dim targetrg as range, cell as range

set targetrg = range("e2:i36")

for counter = 1 to 50

set cell = randcell (targetrg)
cell.interior.color=vbred

next

end sub

The issue that I am having trouble to solve is that when I run the macro cells are randomly selected and filled even if they have already been filled i.e. instead of randomly filling 50 cells, I end with 48 cells being filled because 2 cells have been selected twice.

any help would be greatly appreciated,

thanks,

Paul

[p45cal]

try:

Sub blah()
Dim targetrg As Range, i, CellsToColour As Range, NumberOfCellsToColour As Long, zz(), CellCount, n, j, temp

Set targetrg = Range("e2:i36")    'adjust
NumberOfCellsToColour = 50    'adjust

CellCount = targetrg.Cells.Count
ReDim zz(1 To CellCount)
For i = 1 To CellCount
  zz(i) = i
Next i
For n = 1 To CellCount
  j = CLng(((CellCount - n) * Rnd) + n)
  temp = zz(n)
  zz(n) = zz(j)
  zz(j) = temp
Next n

For i = 1 To NumberOfCellsToColour
  If CellsToColour Is Nothing Then Set CellsToColour = targetrg.Cells(zz(i)) Else Set CellsToColour = Union(CellsToColour, targetrg.Cells(zz(i)))
Next i
CellsToColour.Interior.Color = vbRed
End Sub

[psb1]

That's worked a treat - thanks for your help I REALLY would of struggled!!!

[mikerickson]

Here's another aproach:

Sub test()
    Dim baseRange As Range, rngColor As Range
    Dim nextCell As Range
    Dim colorCount As Long, baseCount As Long
    
    colorCount = 50: Rem adjust
    Set baseRange = Range("E2:I36"): Rem adjust
    
    baseCount = baseRange.Cells.Count
    Set rngColor = baseRange.Item(WorksheetFunction.RandBetween(1, baseCount))
    
    Do Until rngColor.Cells.Count = colorCount
        Set nextCell = baseRange.Item(WorksheetFunction.RandBetween(1, baseCount))
        Set rngColor = Application.Union(rngColor, nextCell)
    Loop
    
    baseRange.Interior.ColorIndex = xlNone
    rngColor.Interior.Color = vbRed
End Sub

[psb1]

The plot thickens....
I've been up all night with this and I bet the answer is staring me in the face - how can I modify the macro for it to run but avoid randomly selecting text filled cells i.e. it will never fill a cell red if it has text.
thanks in advance

[p45cal]

Try:

Sub blah()
Dim i, CellsToColour As Range, NumberOfCellsToColour As Long, zz(), CellCount, n, j, temp

NumberOfCellsToColour = 50    'adjust
With Range("e2:i36")    'adjust
  CellCount = .Cells.Count
  ReDim zz(1 To CellCount)
  k = 0
  For i = 1 To CellCount
    If IsEmpty(.Cells(i)) Then
      k = k + 1
      zz(k) = i
    End If
  Next i
  For n = 1 To k
    j = CLng(((k - n) * Rnd) + n)
    temp = zz(n)
    zz(n) = zz(j)
    zz(j) = temp
  Next n
  For i = 1 To Application.Min(NumberOfCellsToColour, k)
    If CellsToColour Is Nothing Then Set CellsToColour = .Cells(zz(i)) Else Set CellsToColour = Union(CellsToColour, .Cells(zz(i)))
  Next i
  CellsToColour.Interior.Color = vbRed
End With
End Sub

[Paul_Hossler]

Another way

Option Explicit
 
Sub Test_1()
    Dim rColor As Range
    Dim i As Long, j As Long, numToBeFilled As Long, numFilled As Long
    Dim aryRandom() As Double
    
    Set rColor = Range("e2:i36")
    numToBeFilled = 50
    With rColor
        .Interior.ColorIndex = xlColorIndexNone
        
        'hold random number and index into Range
        'use (0) to hold for swap in sort
        ReDim aryRandom(0 To .Cells.Count, 1 To 2)
 
        Randomize
        For i = 1 To .Cells.Count
            
            If Len(.Cells(i)) = 0 Then
                aryRandom(i, 1) = Rnd   '   random for sort
                aryRandom(i, 2) = i     '   Cells number
            Else
                aryRandom(i, 1) = 1#    '   to push to bottom after sort
                aryRandom(i, 2) = i
            End If
        Next i
        'simple bubble sort pushed text cells to bottom
        For i = 1 To .Cells.Count - 1
            For j = i + 1 To .Cells.Count
                If aryRandom(i, 1) > aryRandom(j, 1) Then
                    aryRandom(0, 1) = aryRandom(i, 1)
                    aryRandom(0, 2) = aryRandom(i, 2)
                    aryRandom(i, 1) = aryRandom(j, 1)
                    aryRandom(i, 2) = aryRandom(j, 2)
                    aryRandom(j, 1) = aryRandom(0, 1)
                    aryRandom(j, 2) = aryRandom(0, 2)
                End If
            Next j
        Next i
        
            
        numFilled = 0
        i = 1
        
        Do While (numFilled < numToBeFilled) And (aryRandom(i, 1) <> 1#)
            .Cells(aryRandom(i, 2)).Interior.Color = vbRed
            numFilled = numFilled + 1
            i = i + 1
        Loop
        
        
    End With
End Sub