Abstract

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:

sbRandomNoRepeatBeforeN_01_Screen

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:

sbRandomNoRepeatBeforeN_02_Screen

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.

Appendix – sbRandomNoRepeatBeforeN Code

Please note: this function refers to (needs) sbRandHistogrm.

Please read my Disclaimer.

Option Explicit

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.
'Source (EN): http://www.sulprobil.de/sbrandomnorepeatbeforen_en/
'Source (DE): http://www.berndplumhoff.de/sbrandomnorepeatbeforen_de/
'(C) (P) by Bernd Plumhoff 20-Dec-2012 PB V0.10

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
            Else
                vNames(lN) = ""
                'lCount(lN) = 0 'Not necessary but clean
            End If
            obj.Remove obj.Keys()(lDrawn)
            i = i + 1
        Else
            vR(lRow, lCol) = "Error: Cannot fulfil gap condition!"
        End If
    Next lCol
Next lRow
sbRandomNoRepeatBeforeN = vR
End With
End Function

Please read my Disclaimer.

sbRandomNoRepeatBeforeN.xlsm [22 KB Excel file, open and use at your own risk]