Speeding up random selection from list without replacement

[Telperion]

I have a spreadsheet that randomly selects a value from a list of 200, performs an action, then randomly selects another value, and so on until all values have been selected and actions performed.

Currently I do this with a helper column of RAND() and another helper column of LARGE (1-200), followed by an INDEX/MATCH of the largest value to get my random selection. Works perfectly, no issues. The VBA code I use to generate the next selection also works well, but as I increase the number of items, the Do/Loop Until code works slower and slower as more items are selected since the iterations of the loop increase. Obviously the first runs are essentially instantaneous since all value are available and it only takes 1 loop. When the odds get to be 5/200, or 7/200, or 3/200, the time increases substantially.

Is there a better way of doing this? I'm open to changes.

Private Sub NextAvailable()
'
' Randomly selects next available Item from PickCalc sheet
'
    Set CurrentItem = Range("currentItem")
    Set TotalItems = Range("totalItems")
    Set TotalPicked = Range("totalPicked")
    Set NextPick = Range("NextPick")
    Set RandomizerRange = Range("randomizerrange")

' If all Items are Picked, it displays the text that the picking is complete.
' If you do not run an If check, Excel will enter an infinity loop.
' Do / Loop Until says "Run randomization until unPicked Item appears."
' Items that have already been picked are replaced with a 1 so that
' the Do / Loop Until can easily determine what's still available
    
    If TotalItems = TotalPicked Then
        CurrentItem.Value = "Picking is complete!"
    Else
    
        CurrentItem.FormulaLocal = "=NextPick"
        
        Do
            RandomizerRange.FormulaLocal = "=RAND()"
        Loop Until Application.WorksheetFunction.IsText(NextPick)
    
        RandomizerRange.Copy
        RandomizerRange.PasteSpecial (xlPasteItems)
    
    End If
               
End Sub

[JieJenn]

Instead of using Loop, maybe try use .Find statement.

[shg]

Two functions:

Public Function RandLong(Optional iMin As Long = 1, _
                         Optional iMax As Long = -2147483647, _
                         Optional bVolatile As Boolean = False) As Variant
    
    ' shg 2008
    
    ' UDF wrapper for aiRandLong -- UDF only!

    ' Returns numbers between iMin and iMax to the calling range

    Dim nRow        As Long     ' rows in calling range
    Dim nCol        As Long     ' columns in calling range
    Dim iRow        As Long     ' row index
    Dim iCol        As Long     ' col index
    Dim aiTmp()     As Long     ' 1D temp array
    Dim aiOut()     As Long     ' output array

    If bVolatile Then Application.Volatile True

    With Application.Caller
        nRow = .Rows.Count
        nCol = .Columns.Count
    End With

    ReDim aiOut(1 To nRow, 1 To nCol)
    If iMin = 1 And iMax = -2147483647 Then iMax = nRow * nCol
    aiTmp = aiRandLong(iMin, iMax, nRow * nCol)

    For iRow = 1 To nRow
        For iCol = 1 To nCol
            aiOut(iRow, iCol) = aiTmp((iCol - 1) * nRow + iRow)
        Next iCol
    Next iRow

    RandLong = aiOut
End Function

Public Function aiRandLong(iMin As Long, _
                           iMax As Long, _
                           Optional ByVal n As Long = -1, _
                           Optional bVolatile As Boolean = False) As Long()
    ' shg 2008
    ' UDF or VBA

    ' Fisher-Yates shuffle
    ' Returns a 1-based array of n unique Longs between iMin and iMax inclusive
    
    Dim aiSrc()     As Long     ' array of numbers iMin to iMax
    Dim iSrc        As Long     ' index to aiSrc
    Dim iTop        As Long     ' decreasing upper bound for next selection

    Dim aiOut()     As Long     ' output array
    Dim iOut        As Long     ' index to aiOut

    If bVolatile Then Application.Volatile True

    If n < 0 Then n = iMax - iMin + 1
    If iMin > iMax Or n > (iMax - iMin + 1) Or n < 1 Then Exit Function

    ReDim aiSrc(iMin To iMax)
    ReDim aiOut(1 To n)

    ' init iSrc
    For iSrc = iMin To iMax
        aiSrc(iSrc) = iSrc
    Next iSrc

    iTop = iMax
    For iOut = 1 To n
        ' Pick a number in aiSrc between 1 and iTop, copy to output,
        ' replace with the number at iTop, decrement iTop
        iSrc = Int((iTop - iMin + 1) * Rnd) + iMin
        aiOut(iOut) = aiSrc(iSrc)
        aiSrc(iSrc) = aiSrc(iTop)
        iTop = iTop - 1
    Next iOut

    aiRandLong = aiOut
End Function

The first is a UDF wrapper for the second. E.g., select A1:A10, and array-enter =RandLong().

The second can be called from VBA, e.g.,

myDynamicArray (or myVariant) = aiRandLong(1, 200)

[Telperion]

Thanks for the feedback, I eventually settled on a different method. I created a helper column with formula (=IF(ISNUMBER(I1),"Exclude",ROW()/100000)) to essentially create a primary key for each remaining item.

I then created additional rows that use LARGE (with IFERROR to trap #NUM) to sort the primary key of the table so that all the remaining items are at the top. Then I use INDEX/MATCH to get that item's RAND value and Item name, at which point my final INDEX/MATCH on the LARGEest value returns my selection.

The upshot is that my formula-based automatically sorted table is always only ever displaying valid selections, so the Do/Loop Until routine only runs 1 time as opposed to many times.