Boook.xls
Option Explicit
Function RandomSelection(aRng As Range)
Dim myTarg As Range, _
SrcList, Rslt(), _
i As Long, j As Long, k As Long
Application.Volatile
SrcList = aRng.Value
Set myTarg = Application.Caller
With myTarg
If .Areas.Count > 1 Then
RandomSelection = _
"Function can be used only in a single contiguous range"
Exit Function '<<<<<
End If
If .Rows.Count > 1 And .Columns.Count > 1 Then
RandomSelection = _
"Selected cells must be in a single row or column"
Exit Function '<<<<<
End If
If .Cells.Count > aRng.Cells.Count Then
RandomSelection = _
"Range specified as argument must contain more cells than output selection"
Exit Function '<<<<<
End If
ReDim Rslt(1 To IIf(.Rows.Count > 1, .Rows.Count, .Columns.Count))
End With
j = UBound(SrcList, 1)
For i = LBound(Rslt) To UBound(Rslt)
k = Int(Rnd() * (j - LBound(SrcList, 1) + 1)) + LBound(SrcList, 1)
Rslt(i) = SrcList(k, 1)
SrcList(k, 1) = SrcList(j, 1)
j = j - 1
Next i
If myTarg.Rows.Count > 1 Then
RandomSelection = Application.WorksheetFunction.Transpose(Rslt)
Else
RandomSelection = Rslt
End If
End Function
For i = LBound(Rslt) To UBound(Rslt)
k = Int(Rnd() * (j - LBound(SrcList, 1) + 1)) + LBound(SrcList, 1)
if SrcList(k,1).value <> vbNullstring then Rslt(i) = SrcList(k, 1)
SrcList(k, 1) = SrcList(j, 1)
j = j - 1
Next i
Function RandomSelection(aRng As Range)
Dim myTarg As Range, _
SrcList, Rslt(), _
i As Long, j As Long, k As Long, m As String
Application.Volatile
SrcList = aRng.Value
Set myTarg = Application.Caller
With myTarg
If .Areas.Count > 1 Then
RandomSelection = _
"Function can be used only in a single contiguous range"
Exit Function '<<<<<
End If
If .Rows.Count > 1 And .Columns.Count > 1 Then
RandomSelection = _
"Selected cells must be in a single row or column"
Exit Function '<<<<<
End If
If .Cells.Count > aRng.Cells.Count Then
RandomSelection = _
"Range specified as argument must contain more cells than output selection"
Exit Function '<<<<<
End If
ReDim Rslt(1 To IIf(.Rows.Count > 1, .Rows.Count, .Columns.Count))
End With
j = UBound(SrcList, 1)
For i = LBound(Rslt) To UBound(Rslt)
NextI:
k = Int(Rnd() * (j - LBound(SrcList, 1) + 1)) + LBound(SrcList, 1)
If SrcList(k, 1) = 0 Then GoTo NextI
Rslt(i) = SrcList(k, 1)
SrcList(k, 1) = SrcList(j, 1)
j = j - 1
Next i
If myTarg.Rows.Count > 1 Then
RandomSelection = Application.WorksheetFunction.Transpose(Rslt)
Else
RandomSelection = Rslt
End If
End Function
Option Explicit
Function RandomSelection(aRng As Range)
Dim myTarg As Range, _
SrcList, Rslt(), _
i As Long, j As Long, k As Long, m As String
Application.Volatile
SrcList = aRng.Value
Set myTarg = Application.Caller
With myTarg
If .Areas.Count > 1 Then
RandomSelection = _
"Function can be used only in a single contiguous range"
Exit Function '<<<<<
End If
If .Rows.Count > 1 And .Columns.Count > 1 Then
RandomSelection = _
"Selected cells must be in a single row or column"
Exit Function '<<<<<
End If
If .Cells.Count > aRng.Cells.Count Then
RandomSelection = _
"Range specified as argument must contain more cells than output selection"
Exit Function '<<<<<
End If
ReDim Rslt(1 To IIf(.Rows.Count > 1, .Rows.Count, .Columns.Count))
End With
If Application.WorksheetFunction.Sum(aRng) = 0 Then
RandomSelection = "Range does not contain values"
Exit Function
End If
j = UBound(SrcList, 1)
For i = LBound(Rslt) To UBound(Rslt)
NextI:
k = Int(Rnd() * (j - LBound(SrcList, 1) + 1)) + LBound(SrcList, 1)
If SrcList(k, 1) = 0 Or SrcList(k, 1) = vbNullString Then GoTo NextI
Rslt(i) = SrcList(k, 1)
SrcList(k, 1) = SrcList(j, 1)
j = j - 1
Next i
If myTarg.Rows.Count > 1 Then
RandomSelection = Application.WorksheetFunction.Transpose(Rslt)
Else
RandomSelection = Rslt
End If
End Function
Function RandomSelection(aRng As Range)
Dim myTarg As Range, _
SrcList, Rslt(), _
i As Long, j As Long, k As Long, m As String
Application.Volatile
SrcList = aRng.Value
Set myTarg = Application.Caller
With myTarg
If .Areas.Count > 1 Then
RandomSelection = _
"Function can be used only in a single contiguous range"
Exit Function '<<<<<
End If
If .Rows.Count > 1 And .Columns.Count > 1 Then
RandomSelection = _
"Selected cells must be in a single row or column"
Exit Function '<<<<<
End If
If .Cells.Count > aRng.Cells.Count Or .Cells.Count > Application.WorksheetFunction.Count(Range(aRng.Address)) Then
RandomSelection = _
"Range specified as argument must contain more cells than output selection"
Exit Function '<<<<<
End If
ReDim Rslt(1 To IIf(.Rows.Count > 1, .Rows.Count, .Columns.Count))
End With
If Application.WorksheetFunction.Sum(aRng) = 0 Then
RandomSelection = "Range does not contain values"
Exit Function
End If
j = UBound(SrcList, 1)
For i = LBound(Rslt) To UBound(Rslt)
NextI:
k = Int(Rnd() * (j - LBound(SrcList, 1) + 1)) + LBound(SrcList, 1)
If SrcList(k, 1) = 0 Or SrcList(k, 1) = vbNullString Then GoTo NextI
Rslt(i) = SrcList(k, 1)
SrcList(k, 1) = SrcList(j, 1)
j = j - 1
Next i
If myTarg.Rows.Count > 1 Then
RandomSelection = Application.WorksheetFunction.Transpose(Rslt)
Else
RandomSelection = Rslt
End If
End Function
If you are experiencing a similar issue, please ask a related question
Title | # Comments | Views | Activity |
---|---|---|---|
DBF to ... Converter | 5 | 32 | |
Excel 2010 Text Formatting placing a hyphen in front of text | 3 | 20 | |
Help with Syntax | 9 | 26 | |
Sum iF based on a null cell | 11 | 29 |
Join the community of 500,000 technology professionals and ask your questions.
Connect with top rated Experts
17 Experts available now in Live!