Create a function that select RANDOM number not previously selected-CodePudding

I need assistance from you, I don't know how to solve this due to my poor (and old) programming skills.

How can I create a function in Excel that when activated (via button), pick a random number in a certain range and after that, if activated again, pick another random number in the same range but excluding the number selected before.

Example:
Random (1,50) -> 44
Random (1,50) except 44 -> 39
Random (1,50) except 44,39 -> 2
etc.

Thank you so much and have a nice day

CodePudding user response：

Please, use the next way:

Create a variable on top of the module:

  Private rndArr As Variant

Use the next function:

Function rndUnique() As Integer
     Dim rndNo As Integer, filt
      If UBound(rndArr) = 0 Then
        rndUnique = 0
        MsgBox "Everything has been delivered..."
        Exit Function
    End If
    Randomize
    rndNo = Int((UBound(rndArr) - LBound(rndArr)   1) * Rnd   LBound(rndArr))
    rndUnique = rndArr(rndNo)            'return the array element
    filt = rndArr(rndNo) & "$$$": rndArr(rndNo) = filt 'transform the array elem to be removed
    rndArr = filter(rndArr, filt, False) 'eliminate the consumed number, but returning a 0 based array...
End Function

Call the function in the next way. No need to any range extracted from the sheet. It will be built by code:

Sub extractRndUnique() 'your button Click code:
   If Not IsArray(rndArr) Then rndArr = Evaluate("TRANSPOSE(ROW(1:50))")
   Debug.Print rndUnique 'it will return a different array element
End Sub

The function is able to randomly return from a range of strings, too. Unique, of course. The global array should be loaded from a range. If interested, I can show you how.

Edited:

The next function can be used as UDF, and be called from a cell in a formula:

Function rndUnique() As Integer
     Dim rndNo As Integer, filt
      If Not IsArray(rndArr) Then rndArr = Evaluate("TRANSPOSE(ROW(1:50))")
      If UBound(rndArr) = 0 Then
        rndUnique = 0: Erase rndArr: rndArr = ""
        MsgBox "Everything has been delivered..."
        Exit Function
    End If
    Randomize
    rndNo = Int((UBound(rndArr) - LBound(rndArr)   1) * Rnd   LBound(rndArr))
    rndUnique = rndArr(rndNo)          'return the array element
    filt = rndArr(rndNo) & "$$$": rndArr(rndNo) = filt 'transform the array elem to be removed
    rndArr = filter(rndArr, filt, False)  'eliminate the consumed number, but returning a 0 based array...
End Function

It needs the same global variable declaration (rndArr), and can be called from a cell as:

   =rndUnique()

And it can be called from the button like that:

Sub extractRndUnique() 'your button Click code:
   Range("A1").value = rndUnique 'it will return a different array element
End Sub

CodePudding user response：

If you happen to just only a quick-and-dirty non-VBA way to get a series of "random numbers between 1 to n without repeating" that would be suitable for ad-hoc purposes, we can create a shuffled list of numbers on a worksheet in under 10 seconds.

populate a column (or row) with the desired range of numbers.

in the adjacent row/column put a random number with

The first value is your first "random number without repeating" and so on.

CodePudding user response：

See comments in the code for explanation.

This will write the numbers 1 to 50 into a dictionary. Everytime you call GetUniqueRandomNumber it will pick one item form that dictionary and delete it. It will repeat that until there are no items in the dictionary and then it will fill the dictionary again with numbers 1 to 50.

Option Explicit

Public Sub test()
    Dim i As Long
    For i = 1 To 50
        Debug.Print i, GetUniqueRandomNumber
    Next i
End Sub

Public Function GetUniqueRandomNumber() As Long
    ' initialize dictionary if no elements
    Static dict As Object
    If dict Is Nothing Then
        InitRandomRange dict, 1, 50
    End If
    
    ' pick a random item from the dictionary
    Dim RandomItem As Long
    RandomItem = Int((dict.Count) * Rnd   1)
    
    ' return it to the function
    GetUniqueRandomNumber = dict.items()(RandomItem - 1)
    ' delete it from the dictionary
    dict.Remove dict.items()(RandomItem - 1)
    
    ' remove the dictionary if it is empty so it gets intitialized with 50 new items on the next call
    If dict.Count = 0 Then
        Set dict = Nothing
    End If
End Function

' initialize dicitionary with a number range
Private Sub InitRandomRange(dict As Object, ByVal ValStart As Long, ByVal ValEnd As Long)
    Set dict = CreateObject("Scripting.Dictionary")
    
    Dim i As Long
    For i = ValStart To ValEnd
        dict.Add i, i
    Next i
End Sub

CodePudding user response：

The following code will output 50 (you can change this value at lim = 50) random non-repeating numbers to the range specified as output_location (in my example, C3 but you can easily alter this).

Sub test()
    Dim i As Long, rn As Long, lim As Long
    Dim output_location As Range
    
    lim = 50
    ReDim arr(1 To lim)
    i = 0
    Set output_location = ActiveSheet.Range("C3")
    Do Until arr(lim) <> 0
        DoEvents
        rn = Int(lim * Rnd   1)
        If Not (IsNumeric(Application.Match(rn, arr, 0))) Then
            arr(i   1) = rn
            output_location.Offset(i, 0).Value = rn
            i = i   1
        End If
    Loop
End Sub

CodePudding user response：

Shuffle a 2D One-Based Array Column's Values (`ShuffleDataColumn`)

Sub Test()
' Calls:        RefColumn
'               GetRange
'               ShuffleDataColumn
'               PrintDataColumn
    
    ' Define constants.
    Const wsName As String = "Sheet1"
    Const FirstCellAddress As String = "A2"
    
    ' Reference the first cell ('fCell').
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    Dim fCell As Range: Set fCell = ws.Range(FirstCellAddress)

    ' Reference the (one-column) range ('rg').
    Dim rg As Range: Set rg = RefColumn(fCell)
    
    ' Write the values from the range
    ' to a 2D one-based (one-column) array ('Data').
    Dim Data() As Variant: Data = GetRange(rg)
    
    ' Print before.
    PrintDataColumn Data, , "Before"
    
    ' Shuffle the values in the array.
    ShuffleDataColumn Data
    
    ' Print after.
    PrintDataColumn Data, , "After"

    ' In your procedure, instead of printing the values,
    ' you could do something like the following.
    
    Dim rCount As Long: rCount = rg.Rows.Count ' or UBound(Data, 1)
    
    Dim cValue As Variant
    Dim r As Long
    
    For r = 1 To rCount
        ' Write the r-th random value to a variable...
        cValue = Data(r, 1)
        ' ... and use the variable in the continuation
        ' of the current iteration.
        ' More code...
    Next r

    ' If you want to write the shuffled values to a range starting with
    ' cell 'B2', you could use:
    ws.Range("B2").Resize(rCount).Value = Data

End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      References the one-column range whose first cell is defined
'               by the first cell of a range ('FirstCell') and whose last cell
'               is the bottom-most non-empty cell of the first cell's
'               worksheet column.
' Remarks:      It will fail if the worksheet is filtered.
'               It will not fail if rows or columns are hidden.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Function RefColumn( _
    ByVal FirstCell As Range) _
As Range
    Const ProcName As String = "RefColumn"
    On Error GoTo ClearError
    
    With FirstCell.Cells(1)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row   1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Function
        Set RefColumn = .Resize(lCell.Row - .Row   1)
    End With

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the values of a range ('rg') in a 2D one-based array.
' Remarks:      If ˙rg` refers to a multi-range, only its first area
'               is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
    ByVal rg As Range) _
As Variant
    Const ProcName As String = "GetRange"
    On Error GoTo ClearError
    
    If rg.Rows.Count   rg.Columns.Count = 2 Then ' one cell
        Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
        GetRange = Data
    Else ' multiple cells
        GetRange = rg.Value
    End If

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Shuffles the values in a column ('ColumnIndex')
'               of a 2D one-based array ('Data').
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ShuffleDataColumn( _
        ByRef Data() As Variant, _
        Optional ByVal ColumnIndex As Variant)
    Const ProcName As String = "ShuffleDataColumn"
    On Error GoTo ClearError
    
    Dim c As Long
    If IsMissing(ColumnIndex) Then
        c = LBound(Data, 2)
    Else
        c = CLng(ColumnIndex)
    End If
    
    Dim Temp As Variant, i As Long, j As Long
    For i = UBound(Data, 1) To 2 Step -1
        Temp = Data(i, c)
        j = Int(i * Rnd)   1
        Data(i, c) = Data(j, c)
        Data(j, c) = Temp
    Next

ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Prints the values of a column ('ColumnIndex')
'               of a 2D one-based array ('Data') to the Immediate window.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub PrintDataColumn(Data() As Variant, _
        Optional ByVal ColumnIndex As Variant, _
        Optional ByVal Title As String = "")
    Const ProcName As String = "ShuffleDataColumn"
    On Error GoTo ClearError
    
    If Len(Title) > 0 Then Debug.Print Title
    
    Dim c As Long
    If IsMissing(ColumnIndex) Then
        c = LBound(Data, 2)
    Else
        c = CLng(ColumnIndex)
    End If
    
    Dim r As Long
    For r = 1 To UBound(Data, 1)
        Debug.Print Data(r, c)
    Next r
        
ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Sub

Shuffle a 2D One-Based Array Column's Values (ShuffleDataColumn)

Shuffle a 2D One-Based Array Column's Values (`ShuffleDataColumn`)