Get Random Number Of Unique Items From A Range Or An Array

A few weeks ago, I posted an article showing how to get one or more non-repeating random numbers between a specified range of numbers. The major thing about the code in that article was its efficiency... the loop to retrieve the numbers only executed as many times as the number of requested random numbers asked for... so if you asked for 3 unique random numbers, the loop executed exactly 3 times and then ended.

Well, I decided to expand of this and create a function (usable in other VBA code or in an Excel formula on a worksheet) that will retrieve a specified number of items from a specified array or range looping only as many times as the number of requested items asked for. If you pass in a range, it must be either a single column or single row. If you pass in an array, it can be either one or two dimensional but, if two dimensional, must be equivalent to a single column or a single row (similar to the restriction for a range).

The first argument to the function is the range or array. The function's second argument is optional and specifies how many random items from the array to return... if omitted, this argument defaults to all the elements in the array (in other words, it would randomly shuffle all of the element of the array around).

The function returns a one-dimensional array containing the specified number of randomly selected items from the array. Oh, and I should mention that the elements of the array can be numbers, dates, text, or whatever, as well as any combination of these.

One final note. The code snippet contains two functions... both must be placed in the same code module. The first function (the one you actually call) calls the second function in order to find out how many dimensions a passed in array contains. You can actually use this function separately if you ever need to determine how many dimensions an unknown array has. Okay, I think that is all you need to know... here is the code.

Function RndArr(Data As Variant, Optional HowMany As Variant) As Variant
  Dim X As Long, DimError As Long, RndIdx As Long
  Dim Arr As Variant, Tmp As Variant, Result As Variant
  If TypeOf Data Is Range Then
    If Data.Areas.Count = 1 Then
      If Data.Columns.Count = 1 Then
        Arr = WorksheetFunction.Transpose(Data.Value)
      ElseIf Data.Rows.Count = 1 Then
        Arr = WorksheetFunction.Index(Data.Value, 1, 0)
      End If
    End If
  ElseIf VarType(Data) > 8191 Then
    Arr = Data
    If ArrDimCnt(Arr) = 2 Then
      If UBound(Arr, 1) - LBound(Arr, 1) = 0 Then
        Arr = WorksheetFunction.Index(Arr, 1, 0)
      ElseIf UBound(Arr, 2) - LBound(Arr, 2) = 0 Then
        Arr = WorksheetFunction.Transpose(Arr)
      End If
    End If
  End If
  If IsMissing(HowMany) Then HowMany = UBound(Arr) - LBound(Arr) + 1
  ReDim Result(1 To HowMany)
  For X = 1 To HowMany
    RndIdx = WorksheetFunction.RandBetween(LBound(Arr) + _
             X - 1, UBound(Arr))
    Tmp = Arr(RndIdx)
    Arr(RndIdx) = Arr(LBound(Arr) + X - 1)
    Arr(LBound(Arr) + X - 1) = Tmp
    Result(X) = Tmp
  Next
  RndArr = Result
End Function


Function ArrDimCnt(Arr As Variant) As Long
  Dim X As Long, Tmp As Long
  On Error Resume Next
  For X = 2 To 64
    Tmp = UBound(Arr, X)
    If Err.Number > 0 Then
      ArrDimCnt = X - 1
      Exit For
    End If
    Err.Clear
  Next
  On Error GoTo 0
End Function