Which random number generator does Excel VBA use?
The only piece of information I could obtain about the current (i.e., Excel 365) random number generator used by Excel VBA is Visual Basic for Applications/A PRNG for VBA (a wikibook), which states "Microsoft's Visual Basic for Applications (VBA), at present uses a linear congruential generator (LCG) for pseudo-random number generation in the Rnd() function" and at the bottom "This page was last edited on 16 April 2020, at 06:55." This alone would answer you question.
But since it is not necessarily an authoritative source, you would have to check this. Is Excel VBA's Rnd() really this bad? shows an example for how to do this.
As an alternative, this shows the basic algorithm for Excel's Rnd:
x1 = ( x0 * a + c ) MOD m
Rnd() = x1/m
where:
Rnd() = returned value
m = modulus = (2^24)
x1 = new value
x0 = previous value (initial value 327680)
a = 1140671485
c = 12820163
Repeat length = m = (2^24) = 16,777,216
You may implement it and compare the results it produces with the results from Rnd, and check if it is faithful.
Note: You are right in that this changed across versions. See, e.g., How good is the RAND() function in Excel for Monte Carlo simulation? In particular, the update between 2007 (On the accuracy of statistical procedures in Microsoft Excel 2007) and 2010 (On the accuracy of statistical procedures in Microsoft Excel 2010). Perhaps there's a niche for yet another paper, as of now.
As for alternative generators, in case you don't like what is built-in, there are quite a few out there. A brief list (some are posted in comments) is given here, code is posted below for clarity:
Mersenne Twister in BASIC
VBA Code - Wichmann-Hill (1982)
Is Excel VBA's Rnd() really this bad? (answers there)
Mersenne Twister Random Number Generator Algorithm
Code from links above
- Carmine Arturo Sangiovanni's implementation of Mersenne-Twister
' Visual Basic Mersenne-Twister
' Author: Carmine Arturo Sangiovanni
' carmine @ daygo.com.br
' daygo_gaming @ hotmail.com
'
' Aug 13,2004
'
' based on C++ code
'
'
' Jan 4, 2010
' rev1
' bug fixes sent by Takano Akio (aljee @ hiper.cx)
' look for 'rev1:' to see changes
Option Explicit
Const N = 624
Const M = 397
Global mt(0 To N) As Currency
Global mti As Currency
Dim MATRIX_A As Currency
Dim UPPER_MASK As Currency
Dim LOWER_MASK As Currency
Dim FULL_MASK As Currency
Dim TEMPERING_MASK_B As Currency
Dim TEMPERING_MASK_C As Currency
Function tempering_shift_u(ty As Currency)
tempering_shift_u = f_and(Int(ty / 2048@), FULL_MASK)
End Function
Function tempering_shift_s(ty As Currency)
tempering_shift_s = and_ffffffff(ty * 128@)
End Function
Function tempering_shift_t(ty As Currency)
tempering_shift_t = and_ffffffff(ty * 32768@)
End Function
Function tempering_shift_l(ty As Currency)
tempering_shift_l = f_and(Int(ty / 262144@), FULL_MASK)
End Function
Function f_and(p1 As Currency, p2 As Currency)
Dim v As Currency
Dim i As Integer
If (p1 < UPPER_MASK) And (p2 < UPPER_MASK) Then
f_and = p1 And p2
End If
If (p1 < UPPER_MASK) And (p2 >= UPPER_MASK) Then
f_and = p1 And (p2 - UPPER_MASK)
End If
If (p1 >= UPPER_MASK) And (p2 < UPPER_MASK) Then
f_and = (p1 - UPPER_MASK) And p2
End If
If (p1 >= UPPER_MASK) And (p2 >= UPPER_MASK) Then
f_and = (p1 - UPPER_MASK) And (p2 - UPPER_MASK)
f_and = f_and + UPPER_MASK
End If
End Function
Function f_or(p1 As Currency, p2 As Currency)
Dim v As Currency
Dim i As Integer
Dim f As Boolean
If (p1 < UPPER_MASK) And (p2 < UPPER_MASK) Then
f_or = p1 Or p2
End If
If (p1 < UPPER_MASK) And (p2 >= UPPER_MASK) Then
f_or = p1 Or (p2 - UPPER_MASK)
f_or = f_or + UPPER_MASK
End If
If (p1 >= UPPER_MASK) And (p2 < UPPER_MASK) Then
f_or = (p1 - UPPER_MASK) Or p2 'rev1: replaced 'And' with 'Or'
f_or = f_or + UPPER_MASK
End If
If (p1 >= UPPER_MASK) And (p2 >= UPPER_MASK) Then
f_or = (p1 - UPPER_MASK) Or (p2 - UPPER_MASK) 'rev1: replaced 'And' with 'Or'
f_or = f_or + UPPER_MASK
End If
End Function
Function f_xor(p1 As Currency, p2 As Currency)
Dim v As Currency
Dim i As Integer
Dim f1 As Boolean, f2 As Boolean
If (p1 < UPPER_MASK) And (p2 < UPPER_MASK) Then
f_xor = p1 Xor p2
End If
If (p1 < UPPER_MASK) And (p2 >= UPPER_MASK) Then
f_xor = p1 Xor (p2 - UPPER_MASK)
f_xor = f_xor + UPPER_MASK
End If
If (p1 >= UPPER_MASK) And (p2 < UPPER_MASK) Then
f_xor = (p1 - UPPER_MASK) Xor p2
f_xor = f_xor + UPPER_MASK
End If
If (p1 >= UPPER_MASK) And (p2 >= UPPER_MASK) Then
f_xor = (p1 - UPPER_MASK) Xor (p2 - UPPER_MASK)
End If
End Function
Function f_lower(ByVal p1 As Currency) 'rev1: added ByBal
Do
If p1 < UPPER_MASK Then
f_lower = p1
Exit Do
Else
p1 = p1 - UPPER_MASK
End If
Loop
End Function
Function f_upper(ByVal p1 As Currency) 'rev1: added ByVal
If p1 > LOWER_MASK Then
f_upper = UPPER_MASK
Else
f_upper = 0
End If
End Function
Function f_xor3(p1 As Currency, p2 As Currency, p3 As Currency)
Dim v As Currency
Dim tmp As Currency
Dim i As Integer
Dim f As Integer
If (p1 < UPPER_MASK) And (p2 < UPPER_MASK) Then
tmp = p1 Xor p2
End If
If (p1 < UPPER_MASK) And (p2 >= UPPER_MASK) Then
tmp = p1 Xor (p2 - UPPER_MASK)
tmp = tmp + UPPER_MASK
End If
If (p1 >= UPPER_MASK) And (p2 < UPPER_MASK) Then
tmp = (p1 - UPPER_MASK) Xor p2
tmp = tmp + UPPER_MASK
End If
If (p1 >= UPPER_MASK) And (p2 >= UPPER_MASK) Then
tmp = (p1 - UPPER_MASK) Xor (p2 - UPPER_MASK)
End If
If (tmp < UPPER_MASK) And (p3 < UPPER_MASK) Then
f_xor3 = tmp Xor p3
End If
If (tmp < UPPER_MASK) And (p3 >= UPPER_MASK) Then
f_xor3 = tmp Xor (p3 - UPPER_MASK)
f_xor3 = f_xor3 + UPPER_MASK
End If
If (tmp >= UPPER_MASK) And (p3 < UPPER_MASK) Then
f_xor3 = (tmp - UPPER_MASK) Xor p3
f_xor3 = f_xor3 + UPPER_MASK
End If
If (tmp >= UPPER_MASK) And (p3 >= UPPER_MASK) Then
f_xor3 = (tmp - UPPER_MASK) Xor (p3 - UPPER_MASK)
End If
End Function
Function and_ffffffff(ByVal c As Currency) 'rev1: added ByVal
Dim e As Currency
Dim i As Integer
i = 32
Do
e = 2 ^ (i + 16)
Do While c >= e
c = c - e
Loop
i = i - 1
Loop While i > 15
and_ffffffff = c
End Function
Sub random_init(seed As Currency)
mt(0) = and_ffffffff(seed)
For mti = 1 To N - 1
mt(mti) = and_ffffffff(69069 * mt(mti - 1))
Next mti
End Sub
Function Mersenne_twister_random(max As Integer)
Dim kk As Integer
Dim ty1 As Currency
Dim ty2 As Currency
Dim y As Currency
Dim mag01(0 To 1) As Currency
MATRIX_A = 2567483615@ '&H9908b0df
UPPER_MASK = 2147483648@ '&H80000000
LOWER_MASK = 2147483647@ '&H7fffffff
FULL_MASK = LOWER_MASK + UPPER_MASK '&Hffffffff
TEMPERING_MASK_B = 2636928640@ '&H9d2c5680
TEMPERING_MASK_C = 4022730752@ '&Hefc60000
mag01(0) = 0@
mag01(1) = MATRIX_A
If mti >= N Then
If mti = N + 1 Then
random_init 4537
End If
For kk = 0 To (N - M) - 1
y = f_or(f_upper(mt(kk)), f_lower(mt(kk + 1)))
mt(kk) = f_xor3(mt(kk + M), Int(y / 2@), mag01(f_and(y, 1)))
Next kk
For kk = kk To (N - 1) - 1
y = f_or(f_upper(mt(kk)), f_lower(mt(kk + 1)))
mt(kk) = f_xor3(mt(kk + (M - N)), Int(y / 2@), mag01(f_and(y, 1)))
Next kk
y = f_or(f_upper(mt(N - 1)), f_lower(mt(0)))
mt(N - 1) = f_xor3(mt(M - 1), Int(y / 2@), mag01(f_and(y, 1)))
mti = 0
End If
'---------------------------------------------------
y = mt(mti): mti = mti + 1
'---------------------------------------------------
y = f_xor(y, tempering_shift_u(y))
ty1 = f_and(tempering_shift_s(y), TEMPERING_MASK_B)
y = f_xor(y, ty1)
ty1 = f_and(tempering_shift_t(y), TEMPERING_MASK_C)
y = f_xor(y, ty1)
y = f_xor(y, tempering_shift_l(y))
'---------------------------------------------------
If max = 0 Then
Mersenne_twister_random = 0
Else
Mersenne_twister_random = Int(y / 32) Mod max
End If
End Function
- Code here should be saved as a separate standard module in Excel.
Option Explicit
Dim nSamples As Long
Dim nX As Long, nY As Long, nZ As Long
Sub TestRndX()
'run this to obtain RndX() samples
'Wichmann, Brian; Hill, David (1982), Algorithm AS183:
'An Efficient and Portable Pseudo-Random Number Generator,
'Journal of the Royal Statistical Society. Series C
Dim n As Long
'reset module variables
nX = 0: nY = 0: nZ = 0
RandomizeX
For n = 1 To 10
Debug.Print RndX()
MsgBox RndX()
Next n
'reset module variables
nX = 0: nY = 0: nZ = 0
End Sub
Sub TestScatterChartOfPRNG()
'run this to make a point scatter chart
'using samples from RndX
Dim vA As Variant, n As Long
Dim nS As Long, nR As Double
'remove any other charts
'DeleteAllCharts
'reset module variables
nX = 0: nY = 0: nZ = 0
'set number of samples here
nSamples = 1000
ReDim vA(1 To 2, 1 To nSamples) 'dimension array
'load array with PRNG samples
RandomizeX
For n = 1 To nSamples
nR = RndX()
vA(1, n) = n 'x axis data - sample numbers
vA(2, n) = nR 'y axis data - prng values
Next n
'make scatter point chart from array
ChartScatterPoints vA, 1, 2, nSamples & " Samples of RndX()", _
"Sample Numbers", "PRNG Values [0,1]"
'reset module work variables
nX = 0: nY = 0: nZ = 0
End Sub
Sub RandomizeX(Optional ByVal nSeed As Variant)
'sets variables for PRNG procedure RndX()
Const MaxLong As Double = 2 ^ 31 - 1
Dim nS As Long
Dim nN As Double
'make multiplier
If IsMissing(nSeed) Then
nS = Timer * 60
Else
nN = Abs(Int(Val(nSeed)))
If nN > MaxLong Then 'no overflow
nN = nN - Int(nN / MaxLong) * MaxLong
End If
nS = nN
End If
'update variables
nX = (nS Mod 30269)
nY = (nS Mod 30307)
nZ = (nS Mod 30323)
'avoid zero state
If nX = 0 Then nX = 171
If nY = 0 Then nY = 172
If nZ = 0 Then nZ = 170
End Sub
Function RndX(Optional ByVal nSeed As Long = 1) As Double
'PRNG - gets pseudo random number - use with RandomizeX
'Wichmann-Hill algorithm of 1982
Dim nResult As Double
'initialize variables
If nX = 0 Then
nX = 171
nY = 172
nZ = 170
End If
'first update variables
If nSeed <> 0 Then
If nSeed < 0 Then RandomizeX (nSeed)
nX = (171 * nX) Mod 30269
nY = (172 * nY) Mod 30307
nZ = (170 * nZ) Mod 30323
End If
'use variables to calculate output
nResult = nX / 30269# + nY / 30307# + nZ / 30323#
RndX = nResult - Int(nResult)
End Function
Sub ChartScatterPoints(ByVal vA As Variant, RowX As Long, RowY As Long, _
Optional sTitle As String = "", Optional sXAxis As String, _
Optional sYAxis As String)
'array input must contain two data rows for x and y data
'parameters for user title, x axis and y axis labels
'makes a simple point scatter chart
Dim LBC As Long, UBC As Long, LBR As Long, UBR As Long, n As Long, bOptLim As Boolean
Dim X As Variant, Y As Variant, sX As String, sY As String, sT As String, oC As Chart
LBR = LBound(vA, 1): UBR = UBound(vA, 1)
LBC = LBound(vA, 2): UBC = UBound(vA, 2)
ReDim X(LBC To UBC)
ReDim Y(LBC To UBC)
'labels for specific charts
If sTitle = "" Then sT = "Title Goes Here" Else sT = sTitle
If sXAxis = "" Then sX = "X Axis Label Goes Here" Else sX = sXAxis
If sYAxis = "" Then sY = "Y Axis Label Goes Here" Else sY = sYAxis
If RowX < LBR Or RowX > UBR Or RowY < LBC Or RowY > UBC Then
MsgBox "Parameter data rows out of range in ChartColumns - closing"
Exit Sub
End If
'transfer data to chart arrays
For n = LBC To UBC
X(n) = vA(RowX, n) 'x axis data
Y(n) = vA(RowY, n) 'y axis data
Next n
'make chart
Charts.Add
'set chart type
ActiveChart.ChartType = xlXYScatter 'point scatter chart
'remove unwanted series
With ActiveChart
Do Until .SeriesCollection.Count = 0
.SeriesCollection(1).Delete
Loop
End With
'assign the data and labels to a series
With ActiveChart.SeriesCollection
If .Count = 0 Then .NewSeries
If Val(Application.Version) >= 12 Then
.Item(1).Values = Y
.Item(1).XValues = X
Else
.Item(1).Select
Names.Add "_", X
ExecuteExcel4Macro "series.x(!_)"
Names.Add "_", Y
ExecuteExcel4Macro "series.y(,!_)"
Names("_").Delete
End If
End With
'apply title string, x and y axis strings, and delete legend
With ActiveChart
.HasTitle = True
.ChartTitle.Text = sT
.SetElement (msoElementPrimaryCategoryAxisTitleAdjacentToAxis) 'X
.Axes(xlCategory).AxisTitle.Text = sX
.SetElement (msoElementPrimaryValueAxisTitleRotated) 'Y
.Axes(xlValue).AxisTitle.Text = sY
.Legend.Delete
End With
'trim axes to suit
With ActiveChart
'X Axis
.Axes(xlCategory).Select
.Axes(xlCategory).MinimumScale = 0
.Axes(xlCategory).MaximumScale = nSamples
.Axes(xlCategory).MajorUnit = 500
.Axes(xlCategory).MinorUnit = 100
Selection.TickLabelPosition = xlLow
'Y Axis
.Axes(xlValue).Select
.Axes(xlValue).MinimumScale = -0.2
.Axes(xlValue).MaximumScale = 1.2
.Axes(xlValue).MajorUnit = 0.1
.Axes(xlValue).MinorUnit = 0.05
End With
ActiveChart.ChartArea.Select
Set oC = Nothing
End Sub
Sub DeleteAllCharts5()
'run this to delete all ThisWorkbook charts
Dim oC
Application.DisplayAlerts = False
For Each oC In ThisWorkbook.Charts
oC.Delete
Next oC
Application.DisplayAlerts = True
End Sub
This is a SO link.
This is a workbook for downloading.