Random_Pick
If your selection of cells should determine how many cells you randomly want to pick, take this function, please.
Please notice that you also need my UDF VBUniqRandInt (it is called by this function).
1
Function Random_Pick(ParamArray vrng() _
2
As Variant) As Variant
3
'Returns n random cell contents of multi-range input
4
'[paramarray can be A1:C3, D7:IV88, for example] if n
5
'cells in a worksheet have been selected and the function
6
'has been entered as array formula (CTRL+SHIFT+ENTER).
7
'Reverse("moc.liborplus.www") V0.1 PB 19-Sep-2010
8
Dim vR As Variant, vi As Variant
9
Dim i As Long, j As Long
10
Dim lrow As Long, lcol As Long
11
Dim lpari As Long, lRange As Long
12
13
If TypeName(Application.Caller) <> "Range" Then
14
Random_Pick = CVErr(xlErrRef)
15
Exit Function
16
End If
17
18
ReDim vR(1 To Application.Caller.Rows.Count, _
19
1 To Application.Caller.Columns.Count)
20
ReDim lparidx(LBound(vrng) To UBound(vrng)) As Long
21
22
'Store range counts and sum them up
23
lRange = 0
24
For i = LBound(vrng) To UBound(vrng)
25
lRange = lRange + vrng(i).Count
26
lparidx(i) = vrng(i).Count
27
Next i
28
29
If Application.Caller.Count > lRange Then
30
Random_Pick = CVErr(xlErrValue)
31
Exit Function
32
End If
33
34
lrow = 1
35
lcol = 1
36
For Each vi In VBUniqRandInt( _
37
Application.Caller.Count, lRange)
38
j = vi
39
lpari = LBound(lparidx)
40
Do While j > lparidx(lpari)
41
j = j - lparidx(lpari)
42
lpari = lpari + 1
43
Loop
44
vR(lrow, lcol) = vrng(lpari)(j)
45
lcol = lcol + 1
46
If lcol > UBound(vR, 2) Then
47
lrow = lrow + 1
48
lcol = 1
49
End If
50
Next vi
51
52
Random_Pick = vR
53
54
End Function
Copied!
Here is a version to call from within VBA:
1
Function VBRandom_Pick(lCount As Long, ParamArray vrng() _
2
As Variant) As Variant
3
'Returns lCount random cell contents of multi-range input
4
'[paramarray can be A1:C3, D7:IV88, for example]
5
'Reverse("moc.liborplus.www") V0.1 PB 26-Aug-2012
6
Dim vR As Variant, vi As Variant
7
Dim i As Long, j As Long
8
Dim lrow As Long
9
Dim lpari As Long, lRange As Long
10
11
ReDim vR(1 To lCount)
12
ReDim lparidx(LBound(vrng) To UBound(vrng)) As Long
13
14
'Store range counts and sum them up
15
lRange = 0
16
For i = LBound(vrng) To UBound(vrng)
17
lRange = lRange + vrng(i).Count
18
lparidx(i) = vrng(i).Count
19
Next i
Copied!