Solución:
La única información que pude obtener sobre el generador de números aleatorios actual (es decir, Excel 365) utilizado por Excel VBA es Visual Basic para Aplicaciones / A PRNG para VBA (un wikibook), que dice “Microsoft Visual Basic para Aplicaciones (VBA) , en la actualidad utiliza un generador congruencial lineal (LCG) para la generación de números pseudoaleatorios en la función Rnd () “y en la parte inferior” Esta página se editó por última vez el 16 de abril de 2020, a las 06:55 “. Esto solo respondería a su pregunta.
Pero dado que no es necesariamente una fuente autorizada, debería verificar esto. ¿Es Rnd () de Excel VBA realmente tan malo? muestra un ejemplo de cómo hacer esto.
Como alternativa, esto muestra el algoritmo básico para Excel Rnd:
x1 = ( x0 * a + c ) MOD m
Rnd() = x1/m
dónde:
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
Puede implementarlo y comparar los resultados que produce con los resultados de Rndy compruebe si es fiel.
Nota: Tiene razón en que esto cambió en las versiones. Vea, por ejemplo, ¿Qué tan buena es la función RAND () en Excel para la simulación de Monte Carlo? En particular, la actualización entre 2007 (Sobre la exactitud de los procedimientos estadísticos en Microsoft Excel 2007) y 2010 (Sobre la exactitud de los procedimientos estadísticos en Microsoft Excel 2010). Quizás haya un nicho para otro artículo, a partir de ahora.
En cuanto a los generadores alternativos, en caso de que no le guste lo que está integrado, existen bastantes. Aquí se proporciona una breve lista (algunos se publican en los comentarios), el código se publica a continuación para mayor claridad:
-
Mersenne Twister en BASIC
-
Código VBA – Wichmann-Hill (1982)
-
¿Es Rnd () de Excel VBA realmente tan malo? (responde allí)
-
Algoritmo generador de números aleatorios Mersenne Twister
Código de los enlaces de arriba
- Implementación de Carmine Arturo Sangiovanni de 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 / [email protected]), FULL_MASK)
End Function
Function tempering_shift_s(ty As Currency)
tempering_shift_s = and_ffffffff(ty * [email protected])
End Function
Function tempering_shift_t(ty As Currency)
tempering_shift_t = and_ffffffff(ty * [email protected])
End Function
Function tempering_shift_l(ty As Currency)
tempering_shift_l = f_and(Int(ty / [email protected]), 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 = [email protected] '&H9908b0df
UPPER_MASK = [email protected] '&H80000000
LOWER_MASK = [email protected] '&H7fffffff
FULL_MASK = LOWER_MASK + UPPER_MASK '&Hffffffff
TEMPERING_MASK_B = [email protected] '&H9d2c5680
TEMPERING_MASK_C = [email protected] '&Hefc60000
mag01(0) = [email protected]
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 / [email protected]), 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 / [email protected]), 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 / [email protected]), 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
- El código aquí debe guardarse como un módulo estándar separado en 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
-
Este es un enlace SO.
-
Este es un libro de trabajo para descargar.
Nos puedes corroborar nuestra función exponiendo un comentario o dejando una puntuación te estamos eternamente agradecidos.
¡Haz clic para puntuar esta entrada!
(Votos: 0 Promedio: 0)