Visual Basic for Applications/Knuth 字符串洗牌
- 此代码模块包含用于字符串的 Fisher-Yates 字符洗牌例程，以及用于洗牌一维数组的 Durstenfeld-Knuth 例程。
- 过程 FisherYatesStrShuffle() 对单个字符串的字符进行洗牌。这仅限于在一个字符串中移动单个字符。
- 过程 KnuthArrShuffle() 对一维数组的元素进行排序。该过程仅受数组元素中可以存储的内容的限制。
- 这两种方法是伪随机的且无偏差的。在其他地方，使用随机生成器并不一定能保证结果没有偏差。
- 该代码可以在支持 VBA 的任何 MS Office 应用程序中运行。
- Fisher-Yates 洗牌应用了一种伪随机选择方法。它在这里用于字符串中的字符，但对于数组来说，更常用的方法是相关的 Durstenfeld-Knuth 方法。
- 按顺序对字符串的每个元素进行重新定位，会导致结果字符串的一端严重偏差。Knuth 算法改为在字符串中提出了一个随机位置。然后将该位置的元素累积到输出中，并从原始字符串中删除。后续选择以相同的方式从不断缩短的字符串中进行。
- 请注意，仍然有可能在过程中 不移动 特定的字符，但这只在预期范围内。
- 在顶部过程变量 Cycles 中设置所需的字符串数量。即时窗口已被证明是显示和复制的最佳位置。
- 应该指出的是，任何试图避免 不移动 元素的尝试，不仅会改变洗牌的随机性质，还会阻止使用除非重复字符串以外的任何其他字符串。也就是说，具有重复字符的字符串将无法洗牌。
- 用于数组的 Durstenfeld-Knuth 方法与 Fisher-Yates 实现只有很小的不同。
- 为了减少处理，并且毫无疑问，为了克服在缩短过程中从数组中间删除元素的负担，该算法改为用最后一个元素覆盖为输出选择的元素。在这个 VBA 实现中，数组随后通过 Redim Preserve 方便地缩短了一个元素。
- 参见 Fisher Yates Shuffle，以获得对这两种方法的良好描述。
将下面所有的代码复制到例如 MS Excel 的标准模块中，将工作簿保存为 xlsm 文件类型，并运行任一 test 过程以测试所需的代码。确保打开即时窗口以获取输出。
Option Explicit
Private Sub testFisherYatesStrShuffle()
'run this to test the string shuffle
Dim bOK As Boolean, sStr As String, sR As String
Dim sOut As String, n As Long, Cycles As Long
'set number of shuffled versions needed
Cycles = 1
'test string
sStr = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
For n = 1 To Cycles
bOK = FisherYatesStrShuffle(sStr, sR)
sOut = sR
If bOK = False Then
MsgBox "Problems in shuffle"
Exit Sub
End If
'output to message box and immediate window
'MsgBox "Before : " & sStr & vbCrLf & _
"After : " & sR
Debug.Print "Before : " & sStr
Debug.Print "After : " & sOut & vbCrLf
Next n
End Sub
Private Function FisherYatesStrShuffle(ByVal sIn As String, sOut As String) As Boolean
'Performs a naive Fisher-Yates shuffle on the input string.
'Returns result in sOut. Pseudo random character sequencing.
'Note: Some or all elements could occupy their original positions,
'but only in accordance with expectation based on the random generator.
'This can be seen best for very short character strings, like "ABC".
Dim sL As String, sR As String, sT1 As String, sT2 As String, sMod As String
Dim sAcc As String, i As Long, j As Long, nL As Long, n As Long
'check input string
If sIn = "" Or Len(sIn) < 2 Then
MsgBox "At least 2 characters needed - closing"
Exit Function
End If
'initial assignments
nL = Len(sIn)
sMod = sIn
Randomize
For i = 1 To Len(sIn)
'first get a random number
j = Int((nL - 1 + 1) * Rnd + 1)
'find string value of jth element
sT1 = Mid$(sMod, j, 1)
DoEvents 'allow break
'accumulate jth element
sAcc = sAcc & sT1
'remove current character
sL = Left$(sMod, j - 1)
sR = Right$(sMod, nL - j)
sMod = sL & sR
'new string length
nL = Len(sMod)
DoEvents 'allow break
Next i
'transfer
sOut = sAcc
FisherYatesStrShuffle = True
End Function
Private Sub testKnuthArrShuffle()
'run this to test the array shuffle
Dim bOK As Boolean, sStr As String, sOut As String
Dim Cycles As Long, n As Long, bF As Boolean
Dim vS As Variant, vA As Variant, vB As Variant
'define a typical array for shuffling
vS = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", _
"N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", _
"0", "1", "2", "3", "4", "5", "6", "7", "8", "9")
'set number of shuffled versions needed
Cycles = 1
For n = 1 To Cycles
'shuffle array
bOK = KnuthArrShuffle(vS, vA)
If bOK = False Then
MsgBox "Problems in array shuffle"
Exit Sub
End If
'arrays to strings for display
sStr = Arr1DToStr2(vS)
sOut = Arr1DToStr2(vA)
'display
' MsgBox "Before : " & sStr & vbCrLf & _
' "After : " & sOut
Debug.Print "Before : " & sStr
Debug.Print "After : " & sOut & vbCrLf
'return to an array in vB if needed
bF = StrTo1DArr2(sOut, vB)
Next n
End Sub
Private Function KnuthArrShuffle(vIn As Variant, vR As Variant) As Boolean
' Performs a modified Knuth random shuffle on the elements of the input array.
' The original by Fisher-Yates, was modified for computers by Durstenfeld
' then popularised by Knuth. Returns result in vR with vIn unchanged.
'Note: Some or all elements COULD occupy their original positions,
'but only in accordance with expectation based on the random generator.
'This is best seen for small arrays, say with only 3 elements or so.
Dim vW As Variant
Dim LB As Long, UB As Long, nL As Long
Dim i As Long, j As Long
'initial assignments
LB = LBound(vIn): UB = UBound(vIn)
ReDim vR(LB To UB) 'return array
ReDim vW(LB To UB) 'work array
nL = UB - LB + 1 'length of input array
vW = vIn 'transfer to a work array
'working
Randomize
For i = LB To nL
'first get a random number
j = Int((UB - LB + 1) * Rnd + LB)
'transfer jth of vW to ith of vR
vR(i) = vW(j)
'replace selection with current last of vW
vW(j) = vW(UB)
'remove last of vW by shortening array
ReDim Preserve vW(LB To UB - 1)
'get new UBound of shortened vW
UB = UBound(vW)
'exception; return if last chara
If UB = LB Then
vR(i + 1) = vW(UB)
Exit For
End If
DoEvents 'allow breaks
Next i
KnuthArrShuffle = True
End Function
Function StrTo1DArr2(ByVal sIn As String, vRet As Variant, _
Optional ByVal bLB1 As Boolean = True) As Boolean
' Loads string characters into 1D array (vRet). One per element.
' Optional choice of lower bound. bLB1 = True for one-based (default),
' else bLB1 = False for zero-based. vRet dimensioned in proc.
Dim nC As Long, sT As String
Dim LB As Long, UB As Long
If sIn = "" Then
MsgBox "Empty string - closing"
Exit Function
End If
'allocate array for chosen lower bound
If bLB1 = True Then
ReDim vRet(1 To Len(sIn))
Else
ReDim vRet(0 To Len(sIn) - 1)
End If
LB = LBound(vRet): UB = UBound(vRet)
'load charas of string into array
For nC = LB To UB
If bLB1 = True Then
sT = Mid$(sIn, nC, 1)
Else
sT = Mid$(sIn, nC + 1, 1)
End If
vRet(nC) = sT
Next
StrTo1DArr2 = True
End Function
Function Arr1DToStr2(vIn As Variant) As String
' Makes a single string from 1D array string elements.
' Works for any array bounds.
Dim nC As Long, sT As String, sAccum As String
Dim LB As Long, UB As Long
LB = LBound(vIn): UB = UBound(vIn)
'join characters of array into string
For nC = LB To UB
sT = vIn(nC)
sAccum = sAccum & sT
Next
Arr1DToStr2 = sAccum
End Function
- Fisher Yates Shuffle: 维基百科中写得非常清楚的一篇文章，它一步一步地解释了工作示例。