PDA

View Full Version : Randomly selecting 50 cells from a range & filling with color



psb1
06-16-2018, 01:24 AM
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
06-16-2018, 06:01 AM
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
06-16-2018, 08:44 AM
That's worked a treat - thanks for your help I REALLY would of struggled!!!

mikerickson
06-16-2018, 10:57 AM
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
06-16-2018, 10:45 PM
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
06-17-2018, 10:10 AM
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
06-17-2018, 10:46 AM
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