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

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

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 2

这并不像我想象的那么简单，但是下面的代码在一个数组中存储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 3

要生成唯一编号，您需要对照所有先前生成的编号检查实际生成的编号。

这里是一个例子：

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 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