Excel VBA - 在范围之间生成3个唯一的随机数

Question

我找到了以下代码，并想让它生成 (3) 个唯一随机数，存储在 X、Y 和 Z 变量中。有人可以帮我修改它以添加 (2) 更多存储为变量的随机数，并在代码中指定这些随机数的范围吗？

Sub RandomizeArray(ArrayIn As Variant)
  Dim X As Long, RandomIndex As Long, TempElement As Variant
  Static RanBefore As Boolean
  If Not RanBefore Then
    RanBefore = True
    Randomize
  End If
  If VarType(ArrayIn) >= vbArray Then
    For X = UBound(ArrayIn) To LBound(ArrayIn) Step -1
      RandomIndex = Int((X - LBound(ArrayIn) + 1) * Rnd + LBound(ArrayIn))
      TempElement = ArrayIn(RandomIndex)
      ArrayIn(RandomIndex) = ArrayIn(X)
      ArrayIn(X) = TempElement
    Next
  Else
    'The passed argument was not an array, so put error handler here, such as . . .
    Beep
  End If
End Sub 

我的原始代码需要随机数是唯一的：

Sub FormatSuperProjectHeadings()

        Dim r As Byte, g As Byte, b As Byte
        Dim r2 As Byte, g2 As Byte, b2 As Byte
        Dim spcolor As Integer
            Dim vR(), n As Integer

     'Clear Cells
            n = 3000
            ReDim vR(1 To n)
            For i = 1 To n
                r = WorksheetFunction.RandBetween(0, 127)
                g = WorksheetFunction.RandBetween(0, 127)
                b = WorksheetFunction.RandBetween(0, 127)
                r2 = r + 127
                g2 = g + 127
                b2 = b + 127
                vR(i) = RGB(r2, g2, b2)
            Next i

            Application.ScreenUpdating = False
                Dim MyCell As Range

        With Sheets(1) 'Projects Sheet
            For Each MyCell In .Range("Y5:Y" & .Range("Y" & .Rows.Count).End(xlUp).Row)
                If MyCell = "Super Project" Then
                    MyCell.EntireRow.Interior.Color = vR(WorksheetFunction.RandBetween(1, n))
                    MyCell.Offset(, -22).Font.Bold = True
                End If
            Next
        End With
            Application.ScreenUpdating = True
        End Sub

Answer 1

要生成唯一编号，您需要将实际生成的编号与之前生成的所有编号进行对比。

这是一个例子：

Option Explicit

Public Sub Generate10Numbers()
    Dim Numbers(1 To 10) As Long 'generate 10 numbers
    UniqueRandomNumbersBetween Numbers, 10, 20 'between 10 and 20

    'print all numbers
    Dim No As Variant
    For Each No In Numbers
        Debug.Print No
    Next No
End Sub

Public Function UniqueRandomNumbersBetween(ByRef ReturnNumbers() As Long, LowerBound As Long, UpperBound As Long)
    'check if there are enough numbers to generate them unique
    If UBound(ReturnNumbers) - LBound(ReturnNumbers) > UpperBound - LowerBound Then
        MsgBox "Number range is too small to generate unique numbers"
        Exit Function
    End If

    Dim RndNo As Long
    Dim IsUnique As Boolean

    Dim i As Long, j As Long
    For i = LBound(ReturnNumbers) To UBound(ReturnNumbers)
        Do
            IsUnique = True 'init
            RndNo = WorksheetFunction.RandBetween(LowerBound, UpperBound) 'generate a random number in boundaries
            For j = LBound(ReturnNumbers) To i - 1 'check if it is unique
                If ReturnNumbers(j) = RndNo Then
                    IsUnique = False
                    Exit For
                End If
            Next j
        Loop While Not IsUnique 'loop until a unique number is found
        ReturnNumbers(i) = RndNo 'save the unique number
    Next i
End Function

Answer 2

您可以使用以下函数生成随机数。

Function Random(Low&, High&) As Long
   Randomize
   Random = Int((High - Low + 1) * Rnd + Low)
End Function

那么你的问题就是：

生成 (3) 个唯一随机数，存储在 X、Y 和 Z 变量中

然后您将使用上述函数分配您的x、y 和z 变量。

x = Random(1, 3)
do
    y = Random(1, 3)
loop Until y <> x
do
    z = Random(1, 3)
loop until z <> y and z <> x

我确信有一种更直接的方法可以在不使用循环的情况下执行此操作，但这是一个开始。

Answer 3

这并不像我想象的那么简单，但这里的代码可以在一个数组中存储 3 个（或者根据数组大小最多可以有任意多个）唯一数字：

Sub GetUniqueNumbers()
Dim myarr As Variant
Dim i As Long, j as long
Dim allset As Boolean

ReDim myarr(0 To 2) 'Change array size here

For i = 0 To UBound(myarr)
    Do
        myarr(i) = WorksheetFunction.RandBetween(0, 127) 'Change number range here
        For j = 0 To UBound(myarr)
            If i <> j Then
                If myarr(i) = myarr(j) Then
                    Exit For
                Else
                    If j = UBound(myarr) Then
                        allset = True
                    End If
                End If
            End If
            If j = UBound(myarr) Then
                allset = True
            End If
        Next j
    Loop Until allset = True
    allset = False
Next i

Debug.Print myarr(0)
Debug.Print myarr(1)
Debug.Print myarr(2)
End Sub

将其集成到您现有的代码中：

Dim myarr As Variant
Sub FormatSuperProjectHeadings()

Dim r As Byte, g As Byte, b As Byte
Dim r2 As Byte, g2 As Byte, b2 As Byte
Dim spcolor As Integer
Dim vR(), n As Integer

'Clear Cells
n = 3000
ReDim vR(1 To n)

For i = 1 To n
    Call GetUniqueNumbers

    r = myarr(0)
    g = myarr(1)
    b = myarr(2)

    r2 = r + 127
    g2 = g + 127
    b2 = b + 127
    vR(i) = RGB(r2, g2, b2)

Next i

Application.ScreenUpdating = False

Dim MyCell As Range

With Sheets(1) 'Projects Sheet
    For Each MyCell In .Range("Y5:Y" & .Range("Y" & .Rows.Count).End(xlUp).Row)
        If MyCell = "Super Project" Then
            MyCell.EntireRow.Interior.Color = vR(WorksheetFunction.RandBetween(1, n))
            MyCell.Offset(, -22).Font.Bold = True
        End If
    Next
End With

Application.ScreenUpdating = True

End Sub
Sub GetUniqueNumbers()

Dim i As Long, j As Long
Dim allset As Boolean

ReDim myarr(0 To 2) 'Change array size here

For i = 0 To UBound(myarr)
    Do
        myarr(i) = WorksheetFunction.RandBetween(0, 127) 'Change number range here
        For j = 0 To UBound(myarr)
            If i <> j Then
                If myarr(i) = myarr(j) Then
                    Exit For
                Else
                    If j = UBound(myarr) Then
                        allset = True
                    End If
                End If
            End If
            If j = UBound(myarr) Then
                allset = True
            End If
        Next j
    Loop Until allset = True
    allset = False
Next i

End Sub

Answer 4

如果您希望生成唯一的对象数组，通常会使用字典对象。以下代码将为 3 个变量分配 3 个唯一值

取自 K.Dᴀᴠɪs 答案的随机函数

Sub GenerateUniqueValues()
    Dim Dict As Object: Set Dict = CreateObject("Scripting.Dictionary")
    Dim i As Long, x As Long, y As Long, z As Long

    Do Until Dict.Count = 3
        With Dict
            i = Random(0, 127)
            If Not .Exists(i) Then .Add i, i
        End With
    Loop

    x = Dict.keys()(0)
    y = Dict.keys()(1)
    z = Dict.keys()(2)
    Debug.Print x, y, z

End Sub

Function Random(Low&, High&) As Long
   Randomize
   Random = Int((High - Low + 1) * Rnd + Low)
End Function

* 和集成 *

Sub FormatSuperProjectHeadings()

    Dim Dict As Object: Set Dict = CreateObject("Scripting.Dictionary")

    Dim r As Byte, g As Byte, b As Byte
    Dim r2 As Byte, g2 As Byte, b2 As Byte
    Dim spcolor As Integer
    Dim vR(), n As Integer
    Dim i As Long, j As Long

    'Clear Cells
    n = 3000
    ReDim vR(1 To n)
    For i = 1 To n
        Dict.RemoveAll
        Do Until Dict.Count = 3
            With Dict
                j = Random(0, 127)
                If Not .Exists(j) Then .Add j, j
            End With
        Loop
        r = Dict.keys()(0)
        g = Dict.keys()(1)
        b = Dict.keys()(2)
        r2 = r + 127
        g2 = g + 127
        b2 = b + 127
        vR(i) = RGB(r2, g2, b2)
    Next i

    Application.ScreenUpdating = False
    Dim MyCell As Range
    With Sheets(1) 'Projects Sheet
        For Each MyCell In .Range("Y5:Y" & .Range("Y" & .Rows.Count).End(xlUp).Row)
            If MyCell = "Super Project" Then
                MyCell.EntireRow.Interior.Color = vR(WorksheetFunction.RandBetween(1, n))
                MyCell.Offset(, -22).Font.Bold = True
            End If
        Next
    End With

    Application.ScreenUpdating = True
End Sub

Function Random(Low&, High&) As Long
   Randomize
   Random = Int((High - Low + 1) * Rnd + Low)
End Function