To get a random cell in a filtered range I use this method below but it sometimes selects hidden ones.
How can I restrict random selection to select visible cells?
Set areaRng = Sheet1.Range("table_area").SpecialCells(xlCellTypeVisible)
Dim randomCell As Long
randomCell = Int(Rnd * areaRng.Cells.Count) + 1
On Error Resume Next
With areaRng.Cells(randomCell)
.Select
End With`
Randomize a position within the entire range and cross check that for being within the visible cells.
Dim areaAllRng As Range, areaVisibleRng As Range
Dim randomCell As Long
With Sheet6
Set areaAllRng = .Range("table_area").Cells
Set areaVisibleRng = .Range("table_area").SpecialCells(xlCellTypeVisible)
randomCell = Int(Rnd * areaAllRng.Cells.Count) + 1
Do While Intersect(areaAllRng.Cells(randomCell), areaVisibleRng) Is Nothing
'Debug.Print areaAllRng.Cells(randomCell).Address(0, 0)
randomCell = Int(Rnd * areaAllRng.Cells.Count) + 1
Loop
Debug.Print areaAllRng.Cells(randomCell).Address(0, 0)
areaAllRng.Cells(randomCell).Select
End With
Alternative method that doesn't bias the result but still utilises the Areas property thus avoiding the risk of run time blowing out on random chance
Sub Demo()
Dim rngVisible As Range
Dim arr As Range
Dim CellsToCount As Long
Dim RandCell As Range
Set rngVisible = Sheet1.Range("table_area").SpecialCells(xlCellTypeVisible)
CellsToCount = Int(Rnd * rngVisible.Count) + 1
For Each arr In rngVisible.Areas
If arr.Cells.Count >= CellsToCount Then
Set RandCell = arr.Cells(CellsToCount)
Exit For
Else
CellsToCount = CellsToCount - arr.Cells.Count
End If
Next
RandCell.Select
End Sub
Related
I'm trying to perform an action in VBA on a range of cells. I would like the selection of the cells to be random not in the order of how the range is setup.
Sub Solver_Step_Evo()
Set Rng = GetRange(ThisWorkbook.ActiveSheet.Range("Variable_Range"))
For Each i In Rng
'perform an action on I where I is randomly selected.
Next i
End Sub
My preference is it randomizes the order not just randomly select a cell where a cell can be picked more than once.
Thanks in advance.
Here's a possible solution. I add all of the cells in the relevant range to a collection. Then, I navigate the collection using random indexes. Once an index has been visited, I remove it from the collection and repeat the process.
Does this work for you?
Edit: No need to call the c.Count method for each iteration. We can manage this ourselves ourselves. It would likely be a bit more efficient than calling the object's method.
Sub SuperTester()
Dim c As Collection
Dim rng As Range
Dim cel As Range
Dim idx As Long
Dim remainingCount As Long
Set rng = Range("A2:A17")
Set c = New Collection
For Each cel In rng
c.Add cel
Next cel
remainingCount = c.Count
While remainingCount > 0
idx = WorksheetFunction.RandBetween(1, c.Count)
Debug.Print c.Item(idx).Address
c.Remove idx
remainingCount = remainingCount - 1
Wend
End Sub
You can use WorksheetFunction.RandBetween to get random number between 2 numbers. The numbers will not be unique though. If you want unique then you will have to use a slightly different approach.
Option Explicit
Sub Solver_Step_Evo()
Dim Rng As Range
Set Rng = GetRange(ThisWorkbook.ActiveSheet.Range("Variable_Range"))
Dim lowerBound As Long: lowerBound = 1
Dim UpperBound As Long: UpperBound = Rng.Cells.Count
Dim randomI As Long
Dim i As Long
For i = lowerBound To UpperBound
randomI = Application.WorksheetFunction.RandBetween(lowerBound, UpperBound)
Debug.Print randomI
Next i
End Sub
Try the next function, please:
Function RndCell(rng As Range) As Range
Dim rndRow As Long, rndCol As Long
rndRow = WorksheetFunction.RandBetween(1, rng.rows.count)
rndCol = WorksheetFunction.RandBetween(1, rng.Columns.count)
Set RndCell = rng.cells(rndRow, rndCol)
End Function
It can be tested using the next simple sub:
Sub testSelectRandomCell()
Dim rng As Range
Set rng = Range("A2:D10")
RndCell(rng).Select
End Sub
Edited:
If the random selected cells should not repeat, the function can be adapted in the next way (using a Static array to keep the already selected cells):
Function RndCellOnce(rng As Range, Optional boolClear As Boolean = False) As Range
Dim rndRow As Long, rndCol As Long, k As Long, El, arr1
Static arr
If boolClear And IsArray(arr) Then Erase arr
DoItAgain:
rndRow = WorksheetFunction.RandBetween(1, rng.rows.count)
rndCol = WorksheetFunction.RandBetween(1, rng.Columns.count)
If IsArray(arr) Then
If UBound(arr) = rng.cells.count - 1 Then
rng.Interior.Color = xlNone
ReDim arr(0): GoTo Over
End If
For Each El In arr
If El <> "" Then
arr1 = Split(El, "|")
If CLng(arr1(0)) = rndRow And CLng(arr1(1)) = rndCol Then GoTo DoItAgain
End If
Next El
ReDim Preserve arr(UBound(arr) + 1)
Else
ReDim arr(0)
End If
Over:
arr(UBound(arr)) = rndRow & "|" & rndCol
Set RndCellOnce = rng.cells(rndRow, rndCol)
End Function
It can be tested with the next Sub. In order to visually check it, each selected cell will get a yellow interior color. When all the range cells will be selected (one by one), the static array will be erased and the interior color will be cleaned:
Sub testSelectRandomCell()
Dim rng As Range
Set rng = Range("A2:D10")
With RndCellOnce(rng)
.Interior.Color = vbYellow
.Select
End With
End Sub
I have an Excel-worksheet with different "sections" separated by an empty row. What I want to do is to simple get the row numbers to work with them. Sadly the code is not executing the For-Loop (No failure, just not entering it) but the rowNumber variable is set properly. Did I miss something on the For-Loop?
Sub Foo()
Dim currentSheet As Worksheet
Set currentSheet = activeSheet
emptyRows = FindAllEmptyRows(currentSheet)
End Sub
Function FindAllEmptyRows(sheet As Worksheet) As Variant
Dim emptyRows() As Variant
Dim i As Long, rowNumber As Long
Dim rowCounter As Integer
rowCounter = 1
rowNumber = sheet.UsedRange.Rows.Count
For i = rowNumber To 1
If Cells(i, 1).End(xlToRight).Column = 16384 And Cells(i, 1) = "" Then
emptyRows(rowCounter) = i
rowCounter = rowCounter + 1
End If
Next
FindAllEmptyRows = emptyRows
End Function
If you want to iterate from last row to first you will need to add Step -1.
emptyRows() needs to be sized to fit the data using ReDim
.Column = 16384 should be changed to .Column = sheet.Columns.Count.
I prefer If WorksheetFunction.CountA(sheet.Rows(i)) = 0 Then
Cells needs to be qualified to sheet: sheet.Cells(i, 1)
Refactored Code
Function FindAllEmptyRows(sheet As Worksheet) As Variant
Dim emptyRows() As Variant
Dim i As Long, rowNumber As Long
Dim rowCounter As Integer
rowNumber = sheet.UsedRange.Rows.Count
For i = rowNumber To 1 Step -1
If sheet.Cells(i, 1).End(xlToRight).Column = sheet.Columns.Count And Cells(i, 1) = "" Then
If rowCounter = 0 Then
ReDim emptyRows(0)
Else
ReDim Preserve emptyRows(rowCounter)
End If
emptyRows(rowCounter) = i
rowCounter = rowCounter + 1
End If
Next
FindAllEmptyRows = emptyRows
End Function
SpecialCells
Range.SpecialCells() can be used to divide a Range into areas of cells that meet certain criteria.
MSDN - Range.SpecialCells Method (Excel)
Returns a Range object that represents all the cells that match the specified type and value
OZ Grid
One of the most beneficial Methods in Excel (in my experience) is the SpecialCells Method. When used, it returns a Range Object that represents only those type of cells we specify. For example, one can use the SpecialCells Method to return a Range Object that only contains formulae. In fact, we can, if we wish, even narrow it down further to have our Range Object (containing only formulae) to return only formulae with errors.
Examining the output of this code should give you a good ideas of how to use SpecialCells.
Sub SpecialFoo()
Dim rArea As Range, rBlanks As Range, rFormulas As Range, rConstants As Range, rUnion As Range
Dim sheet As Worksheet
Set sheet = ActiveSheet
On Error Resume Next
Set rBlanks = sheet.UsedRange.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rBlanks Is Nothing Then
For Each rArea In rBlanks.Areas
Debug.Print "rBlanks Areas: "; rArea.Address
Next
End If
On Error Resume Next
Set rFormulas = sheet.UsedRange.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not rFormulas Is Nothing Then
For Each rArea In rFormulas.Areas
Debug.Print "rFormulas Areas: "; rArea.Address
Next
End If
On Error Resume Next
Set rConstants = sheet.UsedRange.SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not rConstants Is Nothing Then
For Each rArea In rConstants.Areas
Debug.Print "rConstants Areas: "; rArea.Address
Next
End If
If Not rFormulas Is Nothing And Not rConstants Is Nothing Then
Set rFormulas = Union(rConstants, rFormulas)
For Each rArea In rFormulas.Areas
Debug.Print "rUnion Areas: "; rArea.Address
Next
End If
End Sub
you have to size emptyRows() before using it
furthermore you could use WorksheetFunction.Count() to check for any value in current row
finally
Function FindAllEmptyRows(sheet As Worksheet) As Variant
Dim emptyRows() As Variant
Dim i As Long, rowNumber As Long, rowCounter As Long
With sheet.UsedRange ' reference passed sheet UsedRange
rowNumber = .Rows.Count
ReDim emptyRows(0 To rowNumber - 1) ' dim the array to the maximum possible size
For i = rowNumber To 1 Step -1 ' step through reference range rows from the last baxkwards to the first
If WorksheetFunction.Count(.Rows(i)) = 0 Then
emptyRows(rowCounter) = i + .Rows(1).Row - 1 ' fill array in current index with current row index
rowCounter = rowCounter + 1 ' update array index
End If
Next
End With
ReDim Preserve emptyRows(0 To rowCounter) ' redim the array according to the actual number of found empty rows
FindAllEmptyRows = emptyRows
End Function
please note that:
emptyRows(rowCounter) = i + .Rows(1).Row - 1
is storing the absolute row index, i.e. the sheet row index, while
emptyRows(rowCounter) = i
would store the relative row index, i.e. the row index withing the UsedRange, which may start from a row different than row 1
Trying to create a keno board where a person can press a button and get 20 random highlighted numbers. The keno board goes from A1 to J10 and this is the code im using to randomize.
Sub GetRandomCell()
Dim i As Integer
i = 1
Do While i < 21
Dim RNG As Range
Set RNG = Range("A1:j10")
Dim randomCell As Long
randomCell = Int(Rnd * RNG.Cells.Count) + 1
With RNG.Cells(randomCell)
.Select
.Interior.Color = vbYellow
End With
i = i + 1
Loop
End Sub
The problem I am running into is it doesnt always generate 20 yellow cells. How do I ensure that there is always 20?
Sub GetRandomCell()
Dim i As Integer
Dim RNG As Range
Set RNG = Range("A1:J10")
Dim randomCell As Long
i = 1
Do While i < 21
randomCell = Int(Rnd * RNG.Cells.Count) + 1
If RNG.Cells(randomCell).Interior.Color <> vbYellow Then
RNG.Cells(randomCell).Interior.Color = vbYellow
i = i + 1
End If
Loop
End Sub
As mentioned by #KenWhite, it's possible (even probable with such a relatively small range) that you have a cell "overwriting" it's already yellow color. Just add a test, as above, that first checks the cell color and if not yellow, then make yellow.
I tried to get the unique value of each column in the range "RD" and display them in single column. I need to create an object ("scripting.Dictionary") where there are just as many as the number of columns in Range "RD". I tried this code but it resulted in "Run time error 13".
Private Sub CommandButton1_Click()
Range(Me.RefEdit1).Name = "RD"
Range(Me.RefEdit2).Name = "OT"
Dim d As Object, c As Variant, i As Long, s As Long
Dim JK As Long
Dim o As Collection
JK = Range("RD").Columns.Count
Set d = CreateObject("Scripting.Dictionary")
For k = 0 To JK + 1
d.Item(k) = CreateObject("Scripting.Dictionary").Item(k)
c = Range("RD").Columns(k + 1)
If d.Exists(k) Then
d.Item(k) = d.Item(k) + 1 'increment
Else
d.Item(k) = 1 'set as 1st occurence
End If
For i = 1 To UBound(c, 1)
d.Item(k)(c(i, 1)) = 1
Next i
Range("OT").Cells((k * 5) + 2, 2).Resize(d.Item(k).Count) = Application.Transpose(d.Item(k).Keys)
Range("OT").Cells((k * 5) + 2, 2).Resize(d.Item(k).Count).Sort Key1:=Range("OT").Cells((k * 5) + 2, 2).Resize(d.Item(k).Count)
Next k
End Sub
I'm adding some code below to help loop through a list, looking for unique values, and adding them to a new column. In my example, I enclose the entire functionality into a single loop for efficiency. I'm also adding the unique values to a new column in Sheet2 starting with cell A1.
Let me know if you need any additional help.
EDITED CODE BASED ON A MISUNDERSTANDING:
Private Sub CommandButton1_Click()
Dim oDict As Object
Dim rngToScrub As Range
Dim rngNewColumnToStoreUnique As Range
Dim oCol As Range
Dim cel As Range
Set rngToScrub = Range(Me.RefEdit1.Value)
Set rngNewColumnToStoreUnique = Sheet2.Range("A1")
For Each oCol In rngToScrub.Columns
Set oDict = CreateObject("Scripting.Dictionary")
For Each cel In oCol.Cells
If oDict.exists(cel.Value) Then
'Do Nothing for Now
Else
oDict.Add cel.Value, 0
rngNewColumnToStoreUnique.Value = cel.Value
Set rngNewColumnToStoreUnique = rngNewColumnToStoreUnique.Offset(1)
End If
Next cel
Set oDict = Nothing
Next oCol
End Sub
Old code: Misunderstood requirements
Private Sub CommandButton1_Click()
Dim oDict As Object
Dim rngToScrub As Range
Dim rngNewColumnToStoreUnique As Range
Dim cel As Range
Set oDict = CreateObject("Scripting.Dictionary")
Set rngToScrub = Range(Me.RefEdit1.Value)
Set rngNewColumnToStoreUnique = Sheet2.Range("A1")
For Each cel In rngToScrub
If oDict.exists(cel.Value) Then
'Do Nothing for Now
Else
oDict.Add cel.Value, 0
rngNewColumnToStoreUnique.Value = cel.Value
Set rngNewColumnToStoreUnique = rngNewColumnToStoreUnique.Offset(1)
End If
Next cel
End Sub
So here is the following VBA code I'm currently using. It works perfectly but I need to expand the range to check additional cells but some of those cells could contain empty cells and I don't want to select those.
Is there a way to bypass those empty cells?
Dim RNG1 As Range
Set RNG1 = Range("H1:H30")
Dim randomCell1 As Long
randomCell1 = Int(Rnd * RNG1.Cells.Count) + 1
With RNG1.Cells(randomCell1)
.Select
'will do something else here, like copy the cell, fill the cell with a color, etc
End With
This should pick only non-empty cells:
Sub marine()
Dim RNG1 As Range, r As Range, c As Collection
Set c = New Collection
Set RNG1 = Range("H1:H30")
For Each r In RNG1
If r.Value <> "" Then
c.Add r
End If
Next r
Dim N As Long
N = Application.WorksheetFunction.RandBetween(1, c.Count)
Set rselect = c.Item(N)
rselect.Select
End Sub
NOTE:
This is an example of a general technique. To make a random pick from a subset of a range, collect the subset and pick from the Collection.
If the values in column H were XlConstants then something like this using SpecialCells
Sub Option_B()
Dim rng1 As Range
Dim rng2 As Range
Dim lngCel As Long
On Error Resume Next
Set rng1 = Range("H1:H30").SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If rng1 Is Nothing Then Exit Sub
Dim randomCell1 As Long
randomCell1 = Int(Rnd * rng1.Cells.Count) + 1
For Each rng2 In rng1.Cells
'kludgy as there will be multiple areas in a SpecialFCells range with blank cells
lngCel = lngCel + 1
If lngCel = randomCell1 Then
Application.Goto rng2
Exit For
End If
Next
End Sub
A bit too late but no harm in posting :)
Sub test()
Dim rng As Range, cel As Range
Dim NErng
Dim i As Integer
Set rng = Range("A1:A15")
For Each cel In rng
If Len(cel) <> 0 Then
If IsArray(NErng) Then
ReDim Preserve NErng(UBound(NErng) + 1)
NErng(UBound(NErng)) = cel.Address
ElseIf IsEmpty(NErng) Then
NErng = cel.Address
Else
NErng = Array(NErng, cel.Address)
End If
End If
Next
i = Int((UBound(NErng) - LBound(NErng) + 1) * Rnd + LBound(NErng))
Debug.Print Range(NErng(i)).Address
End Sub
EDIT -- #brettdj is right. This is adjusted to better answer the "skip these cells" question.
Try this out:
DangThisCellIsBlank:
RandomCell = Int(Rnd * RNG1.Cells.Count) + 1
With RNG1.Cells(RandomCell)
If .Value <> "" Then
'do stuff
Else
'go back and pick another cell
GoTo DangThisCellIsBlank
End If
End With
Try with IsEmpty(RNG1.Cells(randomCell1))
Dim RNG1 As Range
Set RNG1 = Range("H1:H30")
Dim randomCell1 As Long
randomCell1 = Int(Rnd * RNG1.Cells.Count) + 1
'Keep Looping until you find a non empty cell
Do While IsEmpty(RNG1.Cells(randomCell1))
randomCell1 = Int(Rnd * RNG1.Cells.Count) + 1
Loop
'================================================
With RNG1.Cells(randomCell1)
.Select
'will do something else here, like copy the cell, fill the cell with a color, etc
End With