Option Explicit 
 
Function Sample(Source As Range, Take As Long, Optional Replacing As Boolean = False, _ 
    Optional Unique As Boolean = False) 
     
     ' Function by Patrick Matthews
     
     ' Function looks at specified range (Source argument) and returns an array of randomly-
     ' sampled data from that range.  Take argument specifies the number of items in the sample
     
     ' Optional argument Replacing indicates whether sampling is done with replacement (i.e.,
     ' any item in the source may be selected more than once, indicated by True) or without
     ' replacement (any given item may only be selected once, indicated by False)
     
     ' Optional argument Unique indicates whether the samples are drawn from all items in the
     ' Source range (False), or just from the unique elements (True)
     
    Dim Dict As Object 
    Dim Coll As Object 
    Dim xItem As Long 
    Dim cel As Range 
    Dim Results() 
    Dim Counter As Long 
    Dim xKeys As Variant 
     
     ' Reset VBA random number generator
    Randomize 
     
     ' Number of items to draw cannot be larger than the population drawn from
    If Take < 1 Or Take > Source.Cells.Count Then 
        Sample = CVErr(xlErrValue) 
        Exit Function 
    End If 
     
     ' If sample is taken from just unique elements, use Dictionary object
    If Unique Then 
         ' instantiate Dictionary
        Set Dict = CreateObject("Scripting.Dictionary") 
         ' populate Dict with unique keys
        For Each cel In Source.Cells 
            If Not Dict.Exists(cel.Value) Then Dict.Add cel.Value, cel.Value 
        Next 
         ' Retest to see if Take is smaller than our potentially reduced population of unique elements
        If Take > (UBound(Dict.Keys) + 1) Then 
            Sample = CVErr(xlErrValue) 
             ' if Take if OK, proceed with the draw
        Else 
            For Counter = 1 To Take 
                 ' randomly select keys from Dict and put them into dynamic array called Results
                If Counter = 1 Then ReDim Results(1 To 1) Else ReDim Preserve Results(1 To Counter) 
                xKeys = Dict.Keys 
                xItem = Int(Rnd * (UBound(xKeys) + 1)) 
                Results(Counter) = xKeys(xItem) 
                 ' if we are not replacing, then remove the key we just used so it will not be picked again
                If Not Replacing Then Dict.Remove xKeys(xItem) 
            Next 
             ' set function equal to our array
            Sample = Results 
        End If 
        Set Dict = Nothing 
         ' using all elements, so use collection object, which allows repeats
    Else 
         ' instantiate collection
        Set Coll = New Collection 
         ' populate collection
        For Each cel In Source.Cells 
            Coll.Add cel 
        Next 
        For Counter = 1 To Take 
             ' randomly select items from Coll and put them into dynamic array called Results
            If Counter = 1 Then ReDim Results(1 To 1) Else ReDim Preserve Results(1 To Counter) 
            xItem = 1 + Int(Rnd * Coll.Count) 
            Results(Counter) = Coll(xItem) 
             ' if we are not replacing, then remove the item we just used so it will not be picked again
            If Not Replacing Then Coll.Remove xItem 
        Next 
         ' set function equal to our array
        Sample = Results 
        Set Coll = Nothing 
    End If 
     
End Function