Random selection from list

Question

I have a list of items in an Excel worksheet, A1-B115. At the moment I can enter 10 variables which retrieves the correct data from the list.

Code now:

C1=1

Answer 1

This will do the trick.

Sub PickRandomItemsFromList()

    Const nItemsToPick As Long = 10
    Const nItemsTotal As Long = 115

    Dim rngList As Range
    Dim varRandomItems() As Variant
    Dim i As Long

    Set rngList = Range("B1").Resize(nItemsTotal, 1)

    ReDim varRandomItems(1 To nItemsToPick)
    For i = 1 To nItemsToPick
        varRandomItems(i) = rngList.Cells(Int(nItemsTotal * Rnd + 1), 1)
    Next i
    ' varRandomItems now contains nItemsToPick random items from range rngList. 
End Sub

As discussed in the comments, this will allow individual items to be picked more than once within the nItemsToPick picked, if for example number 63 happens to be randomly picked twice. If you don't want this to happen, then an additional loop will have to be added to check whether the item about to be picked is already in the list, for example like so:

Sub PickRandomItemsFromList()

    Const nItemsToPick As Long = 10
    Const nItemsTotal As Long = 115

    Dim rngList As Range
    Dim idx() As Long
    Dim varRandomItems() As Variant
    Dim i As Long
    Dim j As Long
    Dim booIndexIsUnique As Boolean

    Set rngList = Range("B1").Resize(nItemsTotal, 1)

    ReDim idx(1 To nItemsToPick)
    ReDim varRandomItems(1 To nItemsToPick)
    For i = 1 To nItemsToPick
        Do
            booIndexIsUnique = True ' Innoncent until proven guilty
            idx(i) = Int(nItemsTotal * Rnd + 1)
            For j = 1 To i - 1
                If idx(i) = idx(j) Then
                    ' It's already there.
                    booIndexIsUnique = False
                    Exit For
                End If
            Next j
            If booIndexIsUnique = True Then
                Exit Do
            End If
        Loop
        varRandomItems(i) = rngList.Cells(idx(i), 1)
    Next i

    ' varRandomItems now contains nItemsToPick unique random 
    ' items from range rngList. 
End Sub

Note that this will loop forever if nItemsToPick > nItemsTotal !

Answer 2

I would use a collection to make sure you don't get any duplicates.

Function cItemsToPick(NrOfItems As Long, NrToPick As Long) As Collection
    Dim cItemsTotal As New Collection
    Dim K As Long
    Dim I As Long

    Set cItemsToPick = New Collection

    If NrToPick > NrOfItems Then Exit Function

    For I = 1 To NrOfItems
        cItemsTotal.Add I
    Next I

    For I = 1 To NrToPick
        K = Int(cItemsTotal.Count * Rnd + 1)
        cItemsToPick.Add cItemsTotal(K)
        cItemsTotal.Remove (K)
    Next I
    Set cItemsTotal = Nothing
End Function

You can test this function with the following code:

Sub test()
    Dim c As New Collection
    Dim I As Long

    Set c = cItemsToPick(240, 10)
    For I = 1 To c.Count
        Debug.Print c(I)
    Next I
End Sub