How to choose a random minimum count from a range?

[JenniferMurphy]

Given a list of numbers, I need some VBA code to select a random element from those associated with the minimum tally. For example, in this list I would like to select one of the 7's (highlighted in yellow) and return the associated Item (A, D, or F).

Random Minimum Value.xlsx
	C	D	E	F	G	H	I	J
5	Tally	7	9	8	7	10	7	8
6	Item	A	B	C	D	E	F	G
Sheet1

I can think of several solutions that involve looping. For example,

1. Find the minimum value.
2. Count how many there are (N).
3. Generate a random integer (k) on (1,N).
4. Select the item associated with the kth minimum value.

Is there a better way?

 

[Legacy 143009]

For example?

Sub test()
  Dim minVal As Integer, lastCol As Integer, random As Integer, myRange As Variant
  lastCol = Cells(5, Columns.Count).End(xlToLeft).Column
  minVal = Application.WorksheetFunction.Min(Range("D5").Resize(, lastCol - 3))
  myRange = Range("D5").Resize(2, lastCol - 3)
  Do
    random = (((Rnd * Timer) - 1) Mod (lastCol - 3)) + 1
  Loop While minVal <> myRange(1, random)
  MsgBox myRange(2, random)
End Sub

 

[JenniferMurphy]

For example?

Sub test()
  Dim minVal As Integer, lastCol As Integer, random As Integer, myRange As Variant
  lastCol = Cells(5, Columns.Count).End(xlToLeft).Column
  minVal = Application.WorksheetFunction.Min(Range("D5").Resize(, lastCol - 3))
  myRange = Range("D5").Resize(2, lastCol - 3)
  Do
    random = (((Rnd * Timer) - 1) Mod (lastCol - 3)) + 1
  Loop While minVal <> myRange(1, random)
  MsgBox myRange(2, random)
End Sub

It looks like you first identify the range. I should have assigned it to a named range. That would have simplified the code.

Then you find the minimum and select values randomly and loop until you find a minimum value. Is that correct?

For this application, it's fine. But I always worry about code that could theoretically go on forever, however small those odds.

Here's some alternative code I came up with. It makes a single pass through the range. It adds the minimums it finds to a separate array that can then be randomly accessed.

'================================================================================================
'                   Select a Random Cell with Minimum Count

' Scan the first row of the range provided for minimum values.
' Add any found to a separate list.
' Then select one of those at random.

'   pRange is a 2-row range with the tallies in row 1 and the items in row 2
'
' 06/12/23  Created & tested
'================================================================================================
Function RandMinPick(pRange As Range) As String

Dim Tallies As Variant    'Array to hold tallies
Dim MinVal As Long        'The minimum value in the list
Dim MinNdxList() As Long  'The list of minimum value indices
Dim NumMin As Long        'The number of minimum values found
Dim i As Long             'Loop index
Dim RandIndex As Long     'The randomly selected index

Tallies = pRange.Value2                   'Load the data into a VBA array (2 x n)
ReDim MinNdxList(1 To UBound(Tallies, 2)) 'Match array length to data

MinVal = Tallies(1, 1)          'Initialize the minimim value
For i = 1 To UBound(Tallies, 2) 'Loop through tallies
  Select Case Tallies(1, i)       'Check the next tally
    Case Is < MinVal                'If new minimum,
      MinVal = Tallies(1, i)          'Replace it
      NumMin = 1                      'Restart counter
      MinNdxList(NumMin) = i          'Add it to the list
    Case MinVal                     'If another minimum
      NumMin = NumMin + 1             'Increase the count
      MinNdxList(NumMin) = i          'Add its index it to the list
  End Select
Next i

'Select a random index
RandIndex = Application.WorksheetFunction.RandBetween(1, NumMin)
RandMinPick = Tallies(2, MinNdxList(RandIndex)) 'Use the incex to select the item

End Function

I also wrote some test code to call it 1 million times. These are the tallies:

332,452 33.25% 333,722 33.37% 333,826 33.38%

Comments?

 

[Legacy 143009]

Oh no.. Yes, you are totally right. When it comes to randomizing things, I perefer to stay more at heuristic side. I like that brutal force feeling. But it has no practical meaning. At least in this scenario.
Think you have consecutive numbers from 1 to 100000000. Visiting that single 1 at the very begining may take forever. So your infinite loop argument totally makes sense.
On the other hand, you won't take the extra step to filter minimum pairs. But your method will be still efficient I guess

 

[Legacy 143009]

Just my curiosity, if you have time, can you drag race both codes with 10000000 iterations please? I am sure mine will be slower. But how much? It will be a good referance to me for the future.

 

[Eric W]

Another option:

x = Evaluate("LET(m,MIN(D5:J5),c,IF(D5:J5=m,COLUMN(D5:J5)-COLUMN(D5)+1),INDEX(D6:J6,SMALL(c,RANDBETWEEN(1,COUNT(c)))))")

Same basic idea as Jennifer, just written as a formula and evaluated in VBA. Percentages near dead on 33.3%. It could be rewritten to handle and arbitrary range.

 

[JenniferMurphy]

Oh no.. Yes, you are totally right. When it comes to randomizing things, I perefer to stay more at heuristic side. I like that brutal force feeling. But it has no practical meaning. At least in this scenario.
Think you have consecutive numbers from 1 to 100000000. Visiting that single 1 at the very begining may take forever. So your infinite loop argument totally makes sense.
On the other hand, you won't take the extra step to filter minimum pairs. But your method will be still efficient I guess

While my infinite loop argument is theoretically true, in this case, with around a dozen entries, is it is practically irrelevant. Check out these odds:

Random Minimum Value.xlsx
	C	D	E	F	G	H
8	Mins	Total	P(1 miss)	P(10 misses)	P(100 misses)	P(1000 misses)
9	1	10	0.9	0.348678	0.0000	1.74787E-46
10	1	100	0.99	0.904382	0.3660	4.31712E-05
11	1	1,000	0.999	0.990045	0.9048	0.367695425
12	1	10,000	0.9999	0.999000	0.9900	0.904832894
13	1	100,000	0.99999	0.999900	0.9990	0.990049784
14	1	1,000,000	0.999999	0.999990	0.9999	0.999000499
Sheet2

Cell Formulas
Range	Formula
E9:E14	E9	=(D9-C9)/D9
F9:F14	F9	=E9^10
G9:G14	G9	=E9^100
H9:H14	H9	=E9^1000

 

[JenniferMurphy]

Just my curiosity, if you have time, can you drag race both codes with 10000000 iterations please? I am sure mine will be slower. But how much? It will be a good referance to me for the future.

I don't have time to do that right now. Here's the code I used to test my version:

' Quickie test function to see if the items are selected equally
' PickList in the items without spaces (eg, "ADF").
Function RandMinPickTest(pRange As Range, PickList As String, NumTrials As Long) As String
Dim Counts() As Long
ReDim Counts(1 To Len(PickList))
Dim i As Long
Dim Item As String
Dim ItemNdx As Long
Dim msg As String
For i = 1 To NumTrials
  Item = RandMinPick(pRange)
  ItemNdx = InStr(1, PickList, Item)
  If ItemNdx = 0 Then
    MsgBox "Picked item (" & Item & ") not in list"
    Exit Function: End If
  Counts(ItemNdx) = Counts(ItemNdx) + 1
Next i

msg = ""
For i = 1 To Len(PickList)
  msg = msg & " " & Counts(i) & " " & Counts(i) / NumTrials * 100 & "%"
Next i

RandMinPickTest = msg

End Function

 

[JenniferMurphy]

Another option:

x = Evaluate("LET(m,MIN(D5:J5),c,IF(D5:J5=m,COLUMN(D5:J5)-COLUMN(D5)+1),INDEX(D6:J6,SMALL(c,RANDBETWEEN(1,COUNT(c)))))")

Same basic idea as Jennifer, just written as a formula and evaluated in VBA. Percentages near dead on 33.3%. It could be rewritten to handle and arbitrary range.

This is priceless. You didn't work for IBM at one time, did you? Some IBM scientists developed APL (A Programming Language). It was a very interesting language. It used a whole different character set using a lot of greek symbols (iota, rho, etc.). It was unbelievably compact. They used to have contests to see if anyone could write code to do some task in one line.

It looks like it is still around.

APL (programming language) - Wikipedia

en.wikipedia.org

APL syntax and symbols - Wikipedia

en.wikipedia.org

TryAPL

tryapl.org