If you want to perform a random pick on some items (names, numbers, whatever), and these items can occur more than once but you need them not to re-appear within the next N draws, the function shown here will help. It calls sbRandHistoGrm which you will need to include into your VBA code. This function is a fairly advanced example on how to use scripting dictionaries (associative arrays). It shows:
- How to attach values to names (keys)
- How to add, to remove and to change key / value pairs
- How to look up values
- How to access the whole value set as an array
- How to test whether a dictionary is empty (i.e. has no entries)
- How to access values numerically indexed (can be used to numerically index through the key or value set)An example for N = 3:
Please notice that for some data or for some random sequence a solution might be impossible. With the same input data as above but a different random sequence you can get:
As you can see, the single "C" and "D" have been picked already and the additional "A"s or "B" would violate the gap condition of 3 cells in B5.
Function sbRandomNoRepeatBeforeN(rInput As Range, _
lN As Long) As Variant
'From names in rInput we create a random draw into the
'selected cells this function is called from as an array
'function (entered with CTRL + SHIFT + ENTER) so that no
'name re-appears in the next lN cells.
'This function needs / calls sbRandHistogrm.
'Reverse("moc.LiborPlus.www") V0.10 20-Dec-2012 (C) (P) by Bernd Plumhoff
Dim i As Long, j As Long, lDrawn As Long
Dim lCol As Long, lRow As Long
Dim obj As Object
ReDim vNames(1 To lN) As Variant
ReDim lCount(1 To lN) As Long
If TypeName(.Caller) <> "Range" Then
sbRandomNoRepeatBeforeN = CVErr(xlErrRef)
If .Caller.Rows.Count * .Caller.Columns.Count > rInput.Count Then
sbRandomNoRepeatBeforeN = CVErr(xlErrValue)
ReDim vR(1 To .Caller.Rows.Count, 1 To .Caller.Columns.Count)
'First read in all names. They may appear more than once.
Set obj = CreateObject("Scripting.Dictionary")
For i = 1 To rInput.Count
obj.Item(rInput(i).Value) = obj.Item(rInput(i).Value) + 1
'Now apply the draws. After each draw take drawn name out
'for next lN draws.
i = 1
For lRow = 1 To UBound(vR, 1)
For lCol = 1 To UBound(vR, 2)
If obj.Count > 0 Then
lDrawn = sbRandHistogrm(0#, UBound(obj.Items), obj.Items)
vR(lRow, lCol) = obj.Keys()(lDrawn)
If vNames(1) <> "" Then
'Need to add in again a name
obj.Add vNames(1), lCount(1)
For j = 1 To lN - 1
vNames(j) = vNames(j + 1)
lCount(j) = lCount(j + 1)
If obj.Items()(lDrawn) > 1 Then
vNames(lN) = obj.Keys()(lDrawn)
lCount(lN) = obj.Items()(lDrawn) - 1
vNames(lN) = ""
'lCount(lN) = 0 'Not necessary but clean
i = i + 1
vR(lRow, lCol) = "Error: Cannot fulfil gap condition!"
sbRandomNoRepeatBeforeN = vR