使用VBA在单元格范围内生成真正的随机数字

我试图随机分配范围为B4：Z23的单元格，大小为20 X 25，即总共500个单元格应该包含总共500个唯一值，随机值的范围是1到500.因此，每个数字在表格中只能出现一次。 尝试下面的代码，但它在一些单元格中生成重复。

有人能帮我一下吗 ？

Option Explicit Public Sub Random() Dim RandomNumber As Integer Dim i, j As Integer For j = 2 To 26 Randomize RandomNumber = Int((500 - 1 + 1) * Rnd + 1) For i = 4 To 23 With Sheets("Game") Randomize RandomNumber = Int((500 - 1 + 1) * Rnd + 1) Cells(i, j) = RandomNumber End With Next i Next j End Sub 

Answer 1

这里是525个值的示例， B4到Z24中的单元格数目：

 Sub Santosh() Dim Numbers(1 To 525) As Variant Dim i As Long, j As Long, k As Long For k = 1 To 525 Numbers(k) = k Next k Call Shuffle(Numbers) k = 1 For Each r In Range("B4:Z24") r.Value = Numbers(k) k = k + 1 Next r End Sub Sub Shuffle(InOut() As Variant) Dim HowMany As Long, i As Long, j As Long Dim tempF As Double, temp As Variant Hi = UBound(InOut) Low = LBound(InOut) ReDim Helper(Low To Hi) As Double Randomize For i = Low To Hi Helper(i) = Rnd Next i j = (Hi - Low + 1) \ 2 Do While j > 0 For i = Low To Hi - j If Helper(i) > Helper(i + j) Then tempF = Helper(i) Helper(i) = Helper(i + j) Helper(i + j) = tempF temp = InOut(i) InOut(i) = InOut(i + j) InOut(i + j) = temp End If Next i For i = Hi - j To Low Step -1 If Helper(i) > Helper(i + j) Then tempF = Helper(i) Helper(i) = Helper(i + j) Helper(i + j) = tempF temp = InOut(i) InOut(i) = InOut(i + j) InOut(i + j) = temp End If Next i j = j \ 2 Loop End Sub 

Answer 2

因此，这段代码将检查每个生成的随机数，看它是否与之前生成的任何值相同。 如果是这样，它会生成一个新的随机数，直到它是唯一的。

 Option Explicit Public Sub Random() Dim RandomNumber As Integer Dim i, j, k, l As Integer Application.ScreenUpdating = False For j = 2 To 26 For i = 4 To 26 With Sheets("Game") Randomize RandomNumber = Int(500 * Rnd + 1) ' Search through all previous rows & columns (not including the current one) For k = 2 To j - 1 For l = 4 To i - 1 'If the current number is the same as a previous one choose a new one Do While RandomNumber = Cells(l, k) RandomNumber = Int(500 * Rnd + 1) Loop 'Once the number is unique place it in the cell Cells(i, j) = RandomNumber Next l Next k End With Next i Next j End Sub 

Answer 3

另一种解决scheme是通过生成一个二维数组并通过交换随机select的元素来对其进行混洗

 Sub FillRandomNoRepeat(ByRef r As Range) Dim ar() As Integer: ReDim ar(r.Rows.Count - 1, r.Columns.Count - 1) Dim i As Integer, j As Integer For i = 0 To UBound(ar, 1) ar(i, 0) = 1 + i * (1 + UBound(ar, 2)) For j = 1 To UBound(ar, 2) ar(i, j) = 1 + ar(i, j - 1) Next Next ShuffleArray2D ar r.Value = ar End Sub ' This subroutine suffles randomly a bidimensional array, by swapping random elements Sub ShuffleArray2D(ByRef ar As Variant) Randomize Dim i1 As Integer, j1 As Integer, i2 As Integer, j2 As Integer, pass As Integer, temp As Integer For pass = 0 To (1 + UBound(ar, 1)) * (1 + UBound(ar, 2)) * 5 i1 = Int((1 + UBound(ar, 1)) * Rnd): j1 = Int((1 + UBound(ar, 2)) * Rnd) i2 = Int((1 + UBound(ar, 1)) * Rnd): j2 = Int((1 + UBound(ar, 2)) * Rnd) temp = ar(i1, j1): ar(i1, j1) = ar(i2, j2): ar(i2, j2) = temp Next End Sub 

Answer 4

下面的代码原来的想法是保持索引1..n的集合。 在一个循环中，它将随机select一个索引，并将其从集合中删除，以保持唯一性。
不久我就注意到VBA中Collections的速度很慢，我也可以使用一个数组。 这里的技巧是，在随机select之后，数组中的最后一个值保存在刚刚select的位置，并且索引数组缩小一个。 下一个随机select只需要从1..n-1取出，因此不会重复。 它只会select可用的指标。 这和快速数组的使用一样，使得这个algorithm非常快：

 Sub ESPshuffle(ByRef r As Range) ' fill the given range with unique random numbers 1..n ' where n is the number of cells of the range ' 2015-09-20 E/S/P ' algorithm: preset a collection with indices 1..n (= unique) ' and preserve uniqueness when selecting index at random Dim n As Long, nrows As Long, ncols As Long Dim i As Long, j As Long, idx As Long Dim values() As Long Dim arr As Variant arr = r ' range to array, cell content doesnt matter nrows = UBound(arr, 1) ncols = UBound(arr, 2) n = nrows * ncols ' preset values, non-random, so unique ReDim values(1 To n) For i = 1 To n values(i) = i Next i Randomize For i = 1 To nrows For j = 1 To ncols ' choose a random element/index AMONG the remaining idx = Int(n * Rnd + 1) ' index in 1..n arr(i, j) = values(idx) ' remove that element = ' preserve the last element in array, then shorten it by 1 values(idx) = values(n) n = n - 1 Next j Next i ' fill cells in sheet r = arr End Sub 

调用它5000个单元格范围

  ESPshuffle Range("B4:Z203") 

产生这些结果，比较其他两个例程发布在这里：

 Total time in milliseconds, average of 10 repetitions Santosh: 231, max 266 Random_dict (J. Simson): 321, max 359 ESPshuffle: 16, max 47 

Answer 5

还有一种方法可以解决这个问题，但是使用字典来检查重复的值，并使用模数运算符将它们放在正确的单元格中。

  Sub Random() Dim r As Integer, i As Integer, n As Integer, dict As Dictionary Set dict = New Dictionary While n < 525 r = Int(525 * Rnd + 1) If Not dict.Exists(r) Then dict(r) = 0 n = n + 1 If (n Mod 25) = 0 Then i = i + 1 Cells((i Mod 21) + 4, (n Mod 25) + 2) = r End If Wend End Sub 

Answer 6

另一种字典方法，根据初始范围dynamic调整

 Option Explicit Public Sub Random1() Dim ws As Worksheet, d As Object, max1 As Long, max2 As Long Dim i As Long, j As Long, k As Long, arr As Variant Set ws = ThisWorkbook.Worksheets("Game") arr = ws.Range("B4:Z23") 'adjusts based on this initial range max1 = UBound(arr, 1) max2 = UBound(arr, 2) k = max1 * max2 '<--- 500 (B4:Z23) Set d = CreateObject("Scripting.Dictionary") Do j = Int(((k + 1) * Rnd) + 1) 'Rnd returns a single (decimals) If Not d.exists(j) Then i = i + 1 d(j) = i End If Loop While d.Count < k + 1 For i = 0 To max1 - 1 For j = 0 To max2 - 1 arr(i + 1, j + 1) = d(k) k = k - 1 Next Next ws.Range("B4:Z23") = arr End Sub