Excel VBA 使用哪个随机数生成器？
Which random number generator does Excel VBA use?
标题中的问题 - 我想确定 VBA 使用哪个随机数生成器，即在 Randomize 和 Rnd 中？根据 Microsoft 的文档 Excel 本身使用 Mersenne Twister - 这显然非常好，但你不能播种。我似乎无法在 Microsoft 文档中找到 VBA 的答案。
我正在为此使用 Excel 365，因为我知道这可能会因版本而异。
关于 Excel VBA 使用的当前（即 Excel 365）随机数生成器，我可以获得的唯一信息是 Visual Basic for Applications/A PRNG for VBA (a wikibook)，它指出"Microsoft's Visual Basic for Applications (VBA), at present uses a linear congruential generator (LCG) for pseudo-random number generation in the Rnd() function" 和底部 "This page was last edited on 16 April 2020, at 06:55."
仅此一项就可以回答您的问题。
但由于它不一定是权威来源，因此您必须检查一下。
显示了如何执行此操作的示例。
作为替代方案，this 显示了 Excel 的 Rnd 的基本算法：
x1 = ( x0 * a + c ) MOD m
Rnd() = x1/m
其中：
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
您可以实施它并将它产生的结果与 Rnd 的结果进行比较，并检查它是否忠实。
注意：您是对的，因为这在各个版本中都发生了变化。
参见，例如 How good is the RAND() function in Excel for Monte Carlo simulation?
特别是 2007 年 (On the accuracy of statistical procedures in Microsoft Excel 2007) and 2010 (On the accuracy of statistical procedures in Microsoft Excel 2010) 之间的更新。
截至目前，也许还有另一篇论文的利基市场。
至于替代发电机，如果您不喜欢内置的发电机，那里有很多。
这里给出了一个简短的列表（一些张贴在评论中），为了清楚起见，下面张贴了代码：
（那里有答案）
以上 links 中的代码
- Carmine Arturo Sangiovanni 的 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
- 此处的代码应作为单独的标准模块保存在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
这是一个 SO link.
这是一个可供下载的练习册。
您可以从 VBA 访问 Excel 的 RAND 函数 - 令人讨厌的是，它不包含在 Application.WorksheetFunction 中，但是无论如何有一个更快的方法，如果您有Excel365.
下面的代码使用新的 RANDARRAY 函数从 Excel 中提取 1000 个随机数，根据需要使用它们，并根据需要提取更多。一次检索多个，大大提高了速度。
Function RandXLa() As Single
Static Remaining As Long, R() As Variant
If Remaining = 0 Then 'get more numbers if necessary
R = Application.WorksheetFunction.RandArray(1000, 1)
Remaining = 1000
End If
RandXLa = R(Remaining, 1)
Remaining = Remaining - 1
End Function
如果您需要真正的随机数，请研究我的项目VBA.Random。
在其他功能中，匹配不同的用途，它还包含直接替代Rnd：
' 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
标题中的问题 - 我想确定 VBA 使用哪个随机数生成器，即在 Randomize 和 Rnd 中？根据 Microsoft 的文档 Excel 本身使用 Mersenne Twister - 这显然非常好，但你不能播种。我似乎无法在 Microsoft 文档中找到 VBA 的答案。
我正在为此使用 Excel 365，因为我知道这可能会因版本而异。
关于 Excel VBA 使用的当前（即 Excel 365）随机数生成器，我可以获得的唯一信息是 Visual Basic for Applications/A PRNG for VBA (a wikibook)，它指出"Microsoft's Visual Basic for Applications (VBA), at present uses a linear congruential generator (LCG) for pseudo-random number generation in the Rnd() function" 和底部 "This page was last edited on 16 April 2020, at 06:55." 仅此一项就可以回答您的问题。
但由于它不一定是权威来源，因此您必须检查一下。
作为替代方案，this 显示了 Excel 的 Rnd 的基本算法：
x1 = ( x0 * a + c ) MOD m
Rnd() = x1/m
其中：
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
您可以实施它并将它产生的结果与 Rnd 的结果进行比较，并检查它是否忠实。
注意：您是对的，因为这在各个版本中都发生了变化。 参见，例如 How good is the RAND() function in Excel for Monte Carlo simulation? 特别是 2007 年 (On the accuracy of statistical procedures in Microsoft Excel 2007) and 2010 (On the accuracy of statistical procedures in Microsoft Excel 2010) 之间的更新。 截至目前，也许还有另一篇论文的利基市场。
至于替代发电机，如果您不喜欢内置的发电机，那里有很多。 这里给出了一个简短的列表（一些张贴在评论中），为了清楚起见，下面张贴了代码：
以上 links 中的代码
- Carmine Arturo Sangiovanni 的 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
- 此处的代码应作为单独的标准模块保存在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
这是一个 SO link.
这是一个可供下载的练习册。
您可以从 VBA 访问 Excel 的 RAND 函数 - 令人讨厌的是，它不包含在 Application.WorksheetFunction 中，但是无论如何有一个更快的方法，如果您有Excel365.
下面的代码使用新的 RANDARRAY 函数从 Excel 中提取 1000 个随机数，根据需要使用它们，并根据需要提取更多。一次检索多个，大大提高了速度。
Function RandXLa() As Single
Static Remaining As Long, R() As Variant
If Remaining = 0 Then 'get more numbers if necessary
R = Application.WorksheetFunction.RandArray(1000, 1)
Remaining = 1000
End If
RandXLa = R(Remaining, 1)
Remaining = Remaining - 1
End Function
如果您需要真正的随机数，请研究我的项目VBA.Random。
在其他功能中，匹配不同的用途，它还包含直接替代Rnd：
' 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