Function Random_Pick(ParamArray vrng() _ As Variant) As Variant 'Returns n random cell contents of multi-range input '[paramarray can be A1:C3, D7:IV88, for example] if n 'cells in a worksheet have been selected and the function 'has been entered as array formula (CTRL+SHIFT+ENTER). 'Reverse("moc.liborplus.www") V0.1 PB 19-Sep-2010 Dim vR As Variant, vi As Variant Dim i As Long, j As Long Dim lrow As Long, lcol As Long Dim lpari As Long, lRange As Long
If TypeName(Application.Caller) <> "Range" Then Random_Pick = CVErr(xlErrRef) Exit Function End If
ReDim vR(1 To Application.Caller.Rows.Count, _ 1 To Application.Caller.Columns.Count) ReDim lparidx(LBound(vrng) To UBound(vrng)) As Long
'Store range counts and sum them up lRange = 0 For i = LBound(vrng) To UBound(vrng) lRange = lRange + vrng(i).Count lparidx(i) = vrng(i).Count Next i
If Application.Caller.Count > lRange Then Random_Pick = CVErr(xlErrValue) Exit Function End If
lrow = 1 lcol = 1 For Each vi In VBUniqRandInt( _ Application.Caller.Count, lRange) j = vi lpari = LBound(lparidx) Do While j > lparidx(lpari) j = j - lparidx(lpari) lpari = lpari + 1 Loop vR(lrow, lcol) = vrng(lpari)(j) lcol = lcol + 1 If lcol > UBound(vR, 2) Then lrow = lrow + 1 lcol = 1 End If Next vi
Random_Pick = vR
End Function
Here is a version to call from within VBA:
Function VBRandom_Pick(lCount As Long, ParamArray vrng() _ As Variant) As Variant 'Returns lCount random cell contents of multi-range input '[paramarray can be A1:C3, D7:IV88, for example] 'Reverse("moc.liborplus.www") V0.1 PB 26-Aug-2012 Dim vR As Variant, vi As Variant Dim i As Long, j As Long Dim lrow As Long Dim lpari As Long, lRange As Long
ReDim vR(1 To lCount) ReDim lparidx(LBound(vrng) To UBound(vrng)) As Long
'Store range counts and sum them up lRange = 0 For i = LBound(vrng) To UBound(vrng) lRange = lRange + vrng(i).Count lparidx(i) = vrng(i).Count Next i
If lCount > lRange Then VBRandom_Pick = CVErr(xlErrValue) Exit Function End If
lrow = 1 For Each vi In VBUniqRandInt(lCount, lRange) j = vi lpari = LBound(lparidx) Do While j > lparidx(lpari) j = j - lparidx(lpari) lpari = lpari + 1 Loop vR(lrow) = vrng(lpari)(j) lrow = lrow + 1 Next vi
VBRandom_Pick = Application.WorksheetFunction.Transpose(vR)
End Function
|