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.
Please note that this function requires sbRandHistogrm.
Please read my Disclaimer.
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
With Application
'Parameter check
If TypeName(.Caller) <> "Range" Then
sbRandomNoRepeatBeforeN = CVErr(xlErrRef)
Exit Function
End If
If .Caller.Rows.Count * .Caller.Columns.Count > rInput.Count Then
sbRandomNoRepeatBeforeN = CVErr(xlErrValue)
Exit Function
End If
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
Next i
'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)
End If
For j = 1 To lN - 1
vNames(j) = vNames(j + 1)
lCount(j) = lCount(j + 1)
Next j
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
End If
obj.Remove obj.Keys()(lDrawn)
i = i + 1
vR(lRow, lCol) = "Error: Cannot fulfil gap condition!"
End If
Next lCol
Next lRow
sbRandomNoRepeatBeforeN = vR
End With
End Function
Copy link