excel - Excel VBA 使用哪种随机数生成器？

Question

标题中的问题 - 我想确定 VBA 使用哪个随机数生成器，即在 Randomize 和 Rnd 中？根据微软的文档，Excel 本身使用 Mersenne Twister - 这显然非常好，但你不能播种。我似乎无法在 Microsoft 文档中找到 VBA 的答案。

我为此使用 Excel 365，因为我很欣赏这可能会因版本而异。

Answer 1

关于 Excel VBA 使用的当前(即 Excel 365)随机数生成器，我可以获得的唯一信息是 Visual Basic for Applications/A PRNG for VBA (a wikibook) ，其中指出“Microsoft 的 Visual Basic for Applications (VBA)，目前在 Rnd() 函数中使用线性同余生成器 (LCG) 生成伪随机数”，并在底部“此页面最后编辑于 2020 年 4 月 16 日，06:55。”
仅此一项就可以回答您的问题。

但由于它不一定是权威来源，因此您必须检查这一点。
Is Excel VBA's Rnd() really this bad?显示了如何执行此操作的示例。

作为替代方案，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) 和 2010 ( On the accuracy of statistical procedures in Microsoft Excel 2010) 之间的更新。
到目前为止，也许还有另一篇论文的利基市场。

至于替代生成器，如果你不喜欢内置的，那里有很多。
这里给出了一个简短的列表(一些发布在评论中)，为了清楚起见，代码发布在下面:

Mersenne Twister in BASIC

VBA Code - Wichmann-Hill (1982)

Is Excel VBA's Rnd() really this bad? (那里有答案)

Mersenne Twister Random Number Generator Algorithm

来自以上链接的代码

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 链接。

这是一个供下载的工作簿。