MVEs are more concerned with the satisfaction of those they help than with the considerable points they can earn. They are the types of people you feel privileged to call colleagues. Join us in honoring this amazing group of Experts.
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 |
---|---|---|---|
Multiple Open Excel Spreadsheets | 12 | 39 | |
Data in Rows to be converted into single row | 9 | 39 | |
How to copy formulas in 1 column through manual page breaks in Excel | 1 | 21 | |
VB.net Progress Bar - Maximum Value too large | 2 | 8 |
Join the community of 500,000 technology professionals and ask your questions.