With monday.comâ€™s project management tool, you can see what everyone on your team is working in a single glance. Its intuitive dashboards are customizable, so you can create systems that work for you.
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
Boook.xls