Select random cell in range - excel

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

Related

Paste Mulitple cell values into a single cell

I'm trying to copy the values of a range of cells(A1:A50) into a single cell (B1). I can do it manually by copying the cells to the clipboard and then pasting the clipboard into the formuala bar of B1 but I can't find a way of doing this in a macro other than getting the cells copied to the clipboard.
Hopefully someone can help me out here.
Sheet1.Range("A1:A50").SpecialCells(xlCellTypeConstants).Select
Selection.Copy
I would like the contents of cell B1 to look something like this:
Value of cell A1
Value of cell A2
Value of cell A3
...and so on
Just
Sub myConcat(rSource As Range, rTarget As Range, Optional sDelimiter = vbCrLf)
Dim oCell As Range
Dim sRes As String
sRes = vbNullString
For Each oCell In rSource
sRes = sRes & sDelimiter & oCell.Text
Next oCell
rTarget.Value = Right(sRes, Len(sRes) - Len(sDelimiter))
End Sub
Call it from your code like as
Sub tst_myConcat()
Call myConcat([A1:A50], [B1])
End Sub
Of course, this procedure can be easily converted to a function:
Function myConcat(rSource As Range, Optional sDelimiter = vbCrLf)
Dim oCell As Range
Dim sRes As String
sRes = vbNullString
For Each oCell In rSource
sRes = sRes & sDelimiter & oCell.Text
Next oCell
myConcat = Right(sRes, Len(sRes) - Len(sDelimiter))
End Function
In this case, just write in the target cell (B1) =myConcat(A1:A50)
Do not forget to include in the cell format Wrap text!
First Column To String
The FirstColumnToString function (UDF) has a fixed delimiter (Delimiter) which can manually be changed. But it can e.g. do the following:
=FirstColumnToString(A1:A2,A4,A6:C8,Sheet2!A1:A3)
where it will discard error values and zero-length strings ("") and choose only values from the first column of each range e.g. in range A6:C8 it will choose the values from A6:A8.
The Code
Option Explicit
Function FirstColumnToString(ParamArray SourceRanges() As Variant) _
As String
Const Delimiter As String = vbLf & vbLf
Dim RangesCount As Long
RangesCount = UBound(SourceRanges) - LBound(SourceRanges) + 1
Dim data As Variant
ReDim data(1 To RangesCount)
Dim Help As Variant
ReDim Help(1 To 1, 1 To 1)
Dim Element As Variant
Dim RowsCount As Long
Dim j As Long
For Each Element In SourceRanges
j = j + 1
If Element.Rows.Count > 1 Then
data(j) = Element.Columns(1).Value
Else
data(j) = Help
data(j)(1, 1) = Element.Columns(1).Value
End If
RowsCount = RowsCount + UBound(data(j))
Next Element
Dim Result As Variant
ReDim Result(1 To RowsCount)
Dim Current As Variant
Dim i As Long
Dim k As Long
For j = 1 To RangesCount
For i = 1 To UBound(data(j))
Current = data(j)(i, 1)
If Not IsError(Current) Then
If Current <> vbNullString Then
k = k + 1
Result(k) = Current
End If
End If
Next i
Next j
ReDim Preserve Result(1 To k)
FirstColumnToString = Join(Result, Delimiter)
End Function
A much simpler way of doing the job is to use the TREXTJOIN function in Excel:
With Sheet2.Range("A1:A50")
.AutoFilter Field:=1, Criteria1:="<>"
Sheet2.Range("B1").Value2 = WorksheetFunction.TextJoin(vbCrLf, True, _
.SpecialCells(xlCellTypeVisible))
.AutoFilter
End With

Iterate over all rows and find the empty ones of active sheet VBA

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

Extract unique distinct list from two columns

So I am trying to create a combined list from two separate columns by omitting the duplicate items. I have searched and found a formula that combines the list this way by going through one column at a time.
But I want to combine the columns like this:
where it goes through each row first.
Is there a formula or VBA code that does that? Thank you.
EDIT: This is just a way to show my request. The color was added to show how the combined list is sorted, it is not part of the request. The actual lists are each about 500 rows long consisting of 9+ digit ID numbers.
This will put the unique words in the order you want.
Sub foo()
Dim rng As Range
Dim ws As Worksheet
Dim i&, j&, t&
Dim dict As Object
Dim iArr() As Variant
Dim oarr() As Variant
Dim itm As Variant
Set dict = CreateObject("Scripting.Dictionary")
Set ws = ActiveSheet
With ws
Set rng = .Range("A:B").Find("*", .Range("A1"), , , , xlPrevious)
If Not rng Is Nothing Then
iArr = .Range(.Cells(2, 1), .Cells(rng.Row, 2)).Value
For i = LBound(iArr, 1) To UBound(iArr, 1)
For j = LBound(iArr, 2) To UBound(iArr, 2)
If iArr(i, j) <> "" Then
On Error Resume Next
dict.Add iArr(i, j), iArr(i, j)
On Error GoTo 0
End If
Next j
Next i
End If
'If your dataset is not that large <30,000, then you can use it directly with transpose
.Range("C2").Resize(dict.Count) = Application.Transpose(dict.items)
'If your data is large then you will want to put it in a one dimensional array first
'just uncomment the below and comment the one line above
' ReDim oarr(1 To dict.Count, 1 To 1)
' t = 1
' For Each itm In dict.keys
' oarr(t, 1) = dict(itm)
' t = t + 1
' Next itm
' Range("C2").Resize(dict.Count) = oarr
End With
End Sub
UDF solution. Using your provided sample data, put this formula in cell I2 and copy down =UnqList(ROW(I1),$G$2:$H$6) or =UnqList(ROW(I1),$G$2:$G$6,$H$2:$H$6) (it can be either because the two or more lists might not be next to each other and the UDF accounts for that)
Public Function UnqList(ByVal lIndex As Long, ParamArray rLists() As Variant) As Variant
Dim i As Long, j As Long
Dim vList As Variant
Dim cUnq As Collection
Dim lMaxRow As Long, lMaxCol As Long
If lIndex <= 0 Then
UnqList = CVErr(xlErrRef)
Exit Function
End If
For Each vList In rLists
If TypeName(vList) <> "Range" Then
UnqList = CVErr(xlErrRef)
Exit Function
Else
If vList.Rows.Count > lMaxRow Then lMaxRow = vList.Rows.Count
If vList.Columns.Count > lMaxCol Then lMaxCol = vList.Columns.Count
End If
Next vList
Set cUnq = New Collection
For i = 1 To lMaxRow
For j = 1 To lMaxCol
For Each vList In rLists
If i <= vList.Rows.Count And j <= vList.Columns.Count Then
On Error Resume Next
cUnq.Add vList.Cells(i, j).Value, CStr(vList.Cells(i, j).Value)
On Error GoTo 0
If lIndex = cUnq.Count Then
UnqList = cUnq(cUnq.Count)
Set cUnq = Nothing
Exit Function
End If
End If
Next vList
Next j
Next i
UnqList = CVErr(xlErrRef)
Set cUnq = Nothing
End Function
You can use my Duplicate Master addin available via my profile.
Advantages are that the addin provides options to
ignore capitilisation
ignore whitespace
run RegExp replacements (advanced)
further options for deletinf, highlighting, selecting duplicates etc

Loop to create Object excel vba

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

Select Random Cell In A Range Only If It Has A Value - Excel

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

Resources