Truly Random Numbers in VBA

Truly random numbers

The access to true randomness is important in certain areas of math and statistics. Previously, truly random numbers have been either difficult or expensive to retrieve, but with the API from ETH Zürich, everyone can now retrieve a set of random numbers at will for free.

This service is a web API for the quantum random number generator  Quantis developed by the Swiss company ID Qantique:

The Quantis device produced by ID Qantique makes use of the uncertainty of photons based on a Polarising Beam Splitter (PBS), which reflects vertically polarised photons and transmits horizontally polarised photons as illustrated in the figure:

Very innovative idea. Please study the links above for the details and also the white paper:
​ What is the Q in QRNG?​​​

Getting access

The first task is to get access to the API and pass information about which "kind" of random numbers we wish to retrieve and how many. The choice is between integer values and decimal values while the count can be from a single number to many thousands.

An account is not needed, and as the data to retrieve is in Json format, a compact function can be used. The only caveat is, that sometimes the service seems to time out, thus a loop to handle this is included:

' Retrieve a Json response from the service URL of the QRN API.
' Retrieved data is returned in parameter ResponseText.
'
' Returns True if success.
'
' Required reference:
'   Microsoft XML, v6.0
'
' 2019-12-21. Gustav Brock, Cactus Data ApS, CPH.
'
Private Function RetrieveDataResponse( _
    ByVal ServiceUrl As String, _
    ByRef ResponseText As String) _
    As Boolean

    ' ServiceUrl is expected to have URL encoded parameters.
   
    ' Adjustable constants.
    ' Maximum time in seconds to call the service repeatedly
    ' in case of error.
    Const TimeOut           As Integer = 1
   
    ' Fixed constants.
    Const Async             As Boolean = False
    Const StatusOk          As Integer = 200
    Const ErrorNone         As Long = 0
   
    ' Non-caching engine to communicate with the Json service.
    Dim XmlHttp             As New ServerXMLHTTP60
   
    Dim Result              As Boolean
    Dim LastTime            As Date
 
    On Error Resume Next
   
    If ServiceUrl = "" Then
        Err.Raise DtError.dtInvalidProcedureCallOrArgument
    Else
        ' Sometimes a request fails. If so, try a few times more.
        Do
            XmlHttp.Open "GET", ServiceUrl, Async
            XmlHttp.send
            If Err.Number = ErrorNone Then
                Result = True
            Else
                If LastTime = #12:00:00 AM# Then
                    LastTime = Now
                End If
                Debug.Print LastTime, Now
            End If
        Loop Until Result = True Or DateDiff("s", LastTime, Now) > TimeOut
       
        On Error GoTo Err_RetrieveDataResponse
       
        ' Fetch the Json formatted data - or an error message.
        ResponseText = XmlHttp.ResponseText
       
        Select Case XmlHttp.status
            Case StatusOk
                Result = (InStr(ResponseText, ResultHeader) = 1)
            Case Else
                Result = False
        End Select
    End If
   
    RetrieveDataResponse = Result

Exit_RetrieveDataResponse:
    Set XmlHttp = Nothing
    Exit Function

Err_RetrieveDataResponse:
    MsgBox "Error" & Str(Err.Number) & ": " & Err.Description, vbCritical + vbOKOnly, "Web Service Error"
    Resume Exit_RetrieveDataResponse

End Function

This function is the "connector" for the two main functions that will retrieve either a series of integer numbers or decimal numbers.

Retrieve a batch of random numbers

Having the option to connect to the API, it is time to retrieve some random numbers.
This is the function for retrieval of integer numbers where you can specify how many as well as the minimum and maximum value of numbers; the default is simply 0 or 1:

' Retrieves an array of random integer values between a
' minimum and a maximum value.
' By default, only one value of 0 or 1 will be returned.
'
' Arguments:
'   SizeValue:      Count of values retrieved.
'   MinimumValue:   Minimum value that will be retrieved.
'   MaximumValue:   Maximum value that will be retrieved.
'
'   SizeValue should be larger than zero. If not, an array of
'   one element with the value of 0 will be returned.
'   MinimumValue should be smaller than MaximumValue and both
'   should be positive, or unexpected values will be returned.
'
' Acceptable minimum/maximum values are about +/-10E+16.
'
' 2019-12-21. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function QrnIntegers( _
    Optional SizeValue As Long = 1, _
    Optional MinimumValue As Variant = 0, _
    Optional MaximumValue As Variant = 1) _
    As Variant()
   
    ' Path for returning integer values.
    Const IntegerPath       As String = "randint"
    ' Json response with one value.
    Const NeutralResult     As String = "{""result"": [0]}"
    ' Key names must be lowercase.
    Const SizeKey           As String = "size"
    Const MinimumKey        As String = "min"
    Const MaximumKey        As String = "max"

    Dim Values()            As Variant
    Dim TextValues          As Variant
    Dim MinValue            As Variant
    Dim MaxValue            As Variant
    Dim Index               As Long
    Dim ServiceUrl          As String
    Dim Query               As String
    Dim ResponseText        As String
    Dim Result              As Boolean
   
    If IsNumeric(MinimumValue) And IsNumeric(MaximumValue) Then
        If SizeValue > 0 Then
            ' Round to integer as passing a decimal value will cause the service to fail.
            MinValue = Fix(CDec(MinimumValue))
            MaxValue = Fix(CDec(MaximumValue))
               
            Query = BuildUrlQuery( _
                BuildUrlQueryParameter(SizeKey, SizeValue), _
                BuildUrlQueryParameter(MinimumKey, MinValue), _
                BuildUrlQueryParameter(MaximumKey, MaxValue))
               
            ServiceUrl = UrlApi & IntegerPath & Query
           
            Result = RetrieveDataResponse(ServiceUrl, ResponseText)
        End If
   
        If Result = False Then
            Debug.Print ResponseText
            ResponseText = NeutralResult
        End If
       
        ' Example for ResponseText: {"result": [1, 0, 1]}
        TextValues = Split(Split(Split(ResponseText, "[")(1), "]")(0), ", ")
        ReDim Values(LBound(TextValues) To UBound(TextValues))
        ' Convert the text values to Decimal.
        For Index = LBound(TextValues) To UBound(TextValues)
            Values(Index) = CDec(TextValues(Index))
        Next
    End If
   
    QrnIntegers = Values

End Function

As noted in the in-line comments, the received Json string is very simple, thus no fancy code is required to parse it; a triple Split() and a conversion from text to number is all that is needed.

The function for retrieval of decimals is very similar, so it won't be listed here.
Both functions return an array holding the random values, for example, to collect 30 numbers between 10 and 20:

Dim RandomNumbers As Variant
RandomNumbers = QrnIntegers(30, 10, 20)

Pulling one random number

Sometimes you just need a single number. However, it takes about the same time to retrieve one number as several hundreds, and it would be unfriendly to burden the free service with a large count of calls for single numbers.
Thus, functions for retrieval of single numbers are included that - behind the scene - retrieve a batch of numbers and return these one by one as your application will need them.
This is the function for decimal numbers:

' Retrieves one random decimal value that will be equal to or
' larger than 0 (zero) and smaller than 1 (one).
'
' Values will be retrieved from the source in batches to
' relief the burden on the API service and to speed up
' the time to retrieve single values.
'
' The default size of a batch is preset by the constant
' DefaultSize in function QrnDecimalSize.
' The size of the batch (cache) can be preset by calling the function:
'
'   QrnDecimalSize NewCacheSize
'
' Argument Id is for use in a query to force a call of QrnDecimal
' for each record to obtain a random order:
'
'   Select * From SomeTable
'   Order By QrnDecimal([SomeField])
'
' 2019-12-26. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function QrnDecimal( _
    Optional Id As Variant) _
    As Variant

    Static Values           As Variant
    Static LastIndex        As Long
   
    Dim Value               As Variant
   
    If LastIndex = 0 Then
        ' First run, or all values have been retrieved.
        ' Get size of the cache.
        LastIndex = QrnDecimalSize
        ' Retrieve a new set of values.
        Values = QrnDecimals(LastIndex)
    End If
   
    ' Get the next value.
    ' The index of the array is zero-based.
    LastIndex = LastIndex - 1
    Value = Values(LastIndex)
   
    QrnDecimal = Value

End Function

The function for pulling an integer number is similar, so it is not listed here.
By default, they will both retrieve 100 numbers, store them in a static array, and deliver a number when asked. When the last number is used, a new batch of numbers will be retrieved.

The count of numbers - the batch size - can easily be adjusted for special needs - here for the decimal numbers:

' Sets or retrieves the size of the array cached by QrnDecimal.
' To set the size, the new size must be larger than zero.
'
' Example:
'   NewSize = 100
'   QrnDecimalSize NewSize
'   CurrentSize = QrnDecimalSize
'   CurrentSize -> 100
'
' 2019-12-21. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function QrnDecimalSize( _
    Optional Size As Long) _
    As Long

    Const DefaultSize       As Long = 100
   
    Static CurrentSize      As Long
   
    If Size <= 0 Then
        ' Retrieve cache size.
        If CurrentSize = 0 Then
            ' Cache size has not been set. Use default size.
            CurrentSize = DefaultSize
        End If
    Else
        ' Set cache size.
        CurrentSize = Size
    End If
   
    QrnDecimalSize = CurrentSize

End Function

Apart from some helper functions not listed here, only one key function now remains - a function to substitute Rnd().

Substituting VBA.Rnd

Having the above functions at hand, we can now create a true substitute the pseudo random number function of VBA: Rnd().
It takes the same argument and values but - due to the higher resolution - returns a Double, not a Single:

' Returns a true random number as a Double, like Rnd returns a Single.
' The value will be less than 1 but greater than or equal to zero.
'
' Usage: Excactly like Rnd:
'
'   TrueRandomValue = RndQrn[(Number)]
'
'   Number < 0  ->  The same number every time, using Number as the seed.
'   Number > 0  ->  The next number in the pseudo-random sequence.
'   Number = 0  ->  The most recently generated number.
'   No Number   ->  The next number in the pseudo-random sequence.
'
' 2019-12-21. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function RndQrn( _
    Optional ByVal Number As Single = 1) _
    As Double
   
    Static Value            As Double
   
    Select Case Number
        Case Is > 0 Or (Number = 0 And Value = 0)
            ' Return the next number in the random sequence.
            Value = CDbl(QrnDecimal)
        Case Is = 0
            ' Return the most recently generated number.
        Case Is < 0
            ' Not supported by QRN.
            ' Retrieve value from RndDbl.
            Value = RndDbl(Number)
    End Select
   
    ' Return a value like:
    ' 0.171394365283966
    RndQrn = Value
   
End Function

The not listed function RndDbl() returns an artificial Double made from two Single values from Rnd().

Throw the dice

Now it is time for a demo, and what is better than throwing the dice?
A function to demonstrate this is included, ThrowDice. It also demonstrates the use of the functions for setting minimum and maximum numbers for the pips to 1 and 6 respectively:

Public Function ThrowDice( _
    Optional Throws As Integer = 1, _
    Optional Dice As Integer = 1) _
    As Integer()
   
    ' Array dimensions.
    Const DieDimension      As Long = 1
    Const ThrowDimension    As Long = 2
   
    ' Pip values.
    Const MaximumPip        As Double = 6
    Const MinimumPip        As Double = 1
    ' The average pip equals the median pip.
    Const AveragePip        As Double = (MinimumPip + MaximumPip) / 2
    Const NeutralPip        As Double = 0
   
    Dim DiceTrows()         As Integer
    Dim Die                 As Integer
    Dim Throw               As Integer
    Dim Size                As Long
    Dim Total               As Double
   
    If Dice <= 0 Or Throws <= 0 Then
        ' Return one throw of one die with unknown (neutral) result.
        Throws = 1
        Dice = 1
        Size = 0
    Else
        ' Prepare retrieval of values.
        Size = Throws * Dice
        QrnIntegerSize Size
        QrnIntegerMaximum MaximumPip
        QrnIntegerMinimum MinimumPip
    End If
   
    ReDim DiceTrows(1 To Dice, 1 To Throws)

    If Size > 0 Then
        ' Fill array with results.
        For Throw = LBound(DiceTrows, ThrowDimension) To UBound(DiceTrows, ThrowDimension)
            For Die = LBound(DiceTrows, DieDimension) To UBound(DiceTrows, DieDimension)
                DiceTrows(Die, Throw) = QrnInteger
                Total = Total + DiceTrows(Die, Throw)
            Next
        Next
    End If
   
    ' Print header line.
    Debug.Print , ;
    For Die = LBound(DiceTrows, DieDimension) To UBound(DiceTrows, DieDimension)
        Debug.Print "Die" & Str(Die), ;
    Next
    Debug.Print
   
    ' Print results.
    For Throw = LBound(DiceTrows, ThrowDimension) To UBound(DiceTrows, ThrowDimension)
        Debug.Print "Throw" & Str(Throw);
        For Die = LBound(DiceTrows, DieDimension) To UBound(DiceTrows, DieDimension)
            Debug.Print , "   " & DiceTrows(Die, Throw);
        Next
        Debug.Print
    Next
    Debug.Print
   
    ' Print total.
    If DiceTrows(1, 1) = NeutralPip Then
        ' No total to print.
    Else
        Debug.Print "Average pips:", Format(Total / Size, "0.00"), Format((Total / Size - AveragePip) / AveragePip, "Percent") & " off"
        Debug.Print
    End If
   
    ThrowDice = DiceTrows

End Function

It basically contains two loops, one for the throws and one for the dice of the throw, then prints the result.
Here is an example for ThrowDice 6, 4:


The calculated total for this: Average pips: 3,67          4,76% off

Usage in queries

The attached Microsoft Access demo application also includes two queries to demonstrate how the functions can be used in queries.

The first, RandomId, shows how to assign random numbers between 1 and 100 to every record:

SELECT 
    MSysObjects.Name, 
    QrnInteger([Flags]) AS RandomId
FROM 
    MSysObjects
WHERE 
    (((QrnIntegerMinimum(1))>0) AND ((QrnIntegerMaximum(100))>0));

The trick is here, that QrnMinimum and QrnMaximum both will be called once only - and before the query is run - because they are placed in the WHERE clause.

The second, RandomOrder, shows how to randomly order records, in this case the objects from a system table:

SELECT 
    MSysObjects.id, 
    MSysObjects.Name
FROM 
    MSysObjects
ORDER BY 
    QrnDecimal([Flags]);

If you open either of these queries, you will notice, that the numbers in the first and the order of objects in the second will change every time you press Update on the ribbon.

If you wish to learn more about (random) record numbering in Microsoft Access, study my articles:
Sequential Rows in Microsoft Access
Random Rows in Microsoft Access

Conclusion

By taking advantage of a free and extremely reliable public source, offered by ETH Zürich, a complete collection of functions and their typical usage in code as well as in queries, have been presented.
The functions and their flexibility will fulfill every normal requirement for truly random number generation in VBA, typically Microsoft Access and Microsoft Excel.

Code and download

The full code and demos are attached for Microsoft Access 365 and Microsoft Excel 365.


At any time, full and updated code is available on GitHub:   VBA.Random

I hope you found this article useful. You are encouraged to ask questions, report any bugs or make any other comments about it below.
Note: If you need further "Support" about this topic, please consider using the Ask a Question feature of Experts Exchange. I monitor questions asked and would be pleased to provide any additional support required in questions asked in this manner, along with other EE experts.

Please do not forget to press the "Thumbs Up" button if you think this article was helpful and valuable for EE members.