Sulprobil
Search…
sbRandomNoRepatBeforeN
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.
1
Function sbRandomNoRepeatBeforeN(rInput As Range, _
2
lN As Long) As Variant
3
'From names in rInput we create a random draw into the
4
'selected cells this function is called from as an array
5
'function (entered with CTRL + SHIFT + ENTER) so that no
6
'name re-appears in the next lN cells.
7
'This function needs / calls sbRandHistogrm.
8
'Reverse("moc.LiborPlus.www") V0.10 20-Dec-2012 (C) (P) by Bernd Plumhoff
9
Dim i As Long, j As Long, lDrawn As Long
10
Dim lCol As Long, lRow As Long
11
Dim obj As Object
12
ReDim vNames(1 To lN) As Variant
13
ReDim lCount(1 To lN) As Long
14
15
With Application
16
'Parameter check
17
If TypeName(.Caller) <> "Range" Then
18
sbRandomNoRepeatBeforeN = CVErr(xlErrRef)
19
Exit Function
20
End If
21
If .Caller.Rows.Count * .Caller.Columns.Count > rInput.Count Then
22
sbRandomNoRepeatBeforeN = CVErr(xlErrValue)
23
Exit Function
24
End If
25
26
ReDim vR(1 To .Caller.Rows.Count, 1 To .Caller.Columns.Count)
27
28
'First read in all names. They may appear more than once.
29
Set obj = CreateObject("Scripting.Dictionary")
30
For i = 1 To rInput.Count
31
obj.Item(rInput(i).Value) = obj.Item(rInput(i).Value) + 1
32
Next i
33
34
'Now apply the draws. After each draw take drawn name out
35
'for next lN draws.
36
i = 1
37
For lRow = 1 To UBound(vR, 1)
38
For lCol = 1 To UBound(vR, 2)
39
If obj.Count > 0 Then
40
lDrawn = sbRandHistogrm(0#, UBound(obj.Items), obj.Items)
41
vR(lRow, lCol) = obj.Keys()(lDrawn)
42
If vNames(1) <> "" Then
43
'Need to add in again a name
44
obj.Add vNames(1), lCount(1)
45
End If
46
For j = 1 To lN - 1
47
vNames(j) = vNames(j + 1)
48
lCount(j) = lCount(j + 1)
49
Next j
50
If obj.Items()(lDrawn) > 1 Then
51
vNames(lN) = obj.Keys()(lDrawn)
52
lCount(lN) = obj.Items()(lDrawn) - 1
53
Else
54
vNames(lN) = ""
55
'lCount(lN) = 0 'Not necessary but clean
56
End If
57
obj.Remove obj.Keys()(lDrawn)
58
i = i + 1
59
Else
60
vR(lRow, lCol) = "Error: Cannot fulfil gap condition!"
61
End If
62
Next lCol
63
Next lRow
64
sbRandomNoRepeatBeforeN = vR
65
End With
66
End Function
Copied!
sbRandomNoRepeatBeforeN.xlsm
19KB
Binary
sbRandomNoRepeatBeforeN.xlsm
Last modified 1yr ago
Copy link