基於單元格值的代碼複製

Question

我仍然試圖去掌握VBA。

我有下面的代碼，基本上會產生一排彩票號碼。 目前它爲我提供了1-49的5個隨機數和1-10的2個隨機數。

我需要它使值唯一，即沒有5可以是重複的，2不能是彼此相同的。

此外，如果我要在單元格「A1」中有多少行，你想在「E1」中輸入一個數字，我如何生成「E1」中所述的行數？

Sub Lotto() 
Application.ScreenUpdating = False 
Dim I, choose, numbers(49) As Integer 

Range("G2").Select 
For I = 1 To 49 
    numbers(I) = I 
Next 

Randomize Timer 
For I = 1 To 5 
    choose = 1 + Application.Round(Rnd * (49 - I), 0) 
    ActiveCell.Offset(0, I - 1).Value = numbers(choose) 
    numbers(choose) = numbers(40 - I) 
Next 

ActiveCell.Range("A2:N2").Select 
Selection.Sort Key1:=ActiveCell, Order1:=xlAscending, Header:= _ 
xlGuess, OrderCustom:=1, MatchCase:=True, Orientation:= _ 
xlLeftToRight 
Range("a3").Select 
ActiveCell.Select 


Range("M2").Select 
For J = 1 To 10 
    numbers(J) = J 
Next 

Randomize Timer 
For J = 1 To 2 
    choose = 1 + Application.Round(Rnd * (10 - J), 0) 
    ActiveCell.Offset(0, J - 1).Value = numbers(choose) 
    numbers(choose) = numbers(10 - J) 
Next 

ActiveCell.Range("M2:N2").Select 
Selection.Sort Key1:=ActiveCell, Order1:=xlAscending, Header:= _ 
xlGuess, OrderCustom:=1, MatchCase:=True, Orientation:= _ 
xlLeftToRight 
Range("a4").Select 
ActiveCell.Select 


Application.ScreenUpdating = False 
End Sub 

Answer 1

將一個類添加到名爲UniqueRand的項目中，並粘貼下面的代碼。我們的想法是創造獨特價值的數組，隨機混合，然後通過數組進行迭代，以獲得一個隨機值：

Private mValues() As Integer 
Private mPoolSize As Integer 
Private mCurrIdx As Integer 
Private mRecycle As Boolean 

' reuse the same sequence if true 
' reshuffle the order if false 
Public Property Let Recycle(rec As Boolean) 
    mRecycle = rec 
End Property 

' Set the size of the random number pool to 1 to Size 
Public Property Let Size(sz As Integer) 
    mPoolSize = sz 
    ReDim mValues(sz) 
    ShufflePool 
End Property 

' return the next random value from the pool 
Public Property Get NextRand() As Integer 
    NextRand = mValues(mCurrIdx) 
    mCurrIdx = mCurrIdx + 1 
    If mCurrIdx = mPoolSize Then 
     mCurrIdx = 0 
     If Not mRecycle Then 
      ShufflePool 
     End If 
    End If 
End Property 

Private Sub Class_Initialize() 
    mPoolSize = 0 
    mCurrIdx = 0 
    mRecycle = True 
End Sub 

' internal method to generate random ints from min to max 
Private Function RandBetween(min As Integer, max As Integer) As Integer 
    RandBetween = min + CInt(Rnd() * (max - min)) 
End Function 

Private Sub ShufflePool() 
    If mPoolSize = 0 Then 
     Exit Sub 
    End If 

    For i = 0 To mPoolSize - 1 
     mValues(i) = i + 1 
    Next i 

    ' swap values at randomly selected index 
    Dim tmp 
    For i = 0 To mPoolSize - 1 
     Dim idx 
     idx = RandBetween(1, mPoolSize) 
     tmp = mValues(i) 
     mValues(i) = mValues(idx) 
     mValues(idx) = tmp 
    Next i 
End Sub 

您可以使用類的一個單獨的實例以隨機列表。 關於如何從E5值填充行，只是參考E5和細胞想直接填充：

Sub PopulateRow() 

    Dim sheet As Worksheet 
    Dim ur As UniqueRand 
    Dim nValues As Integer 
    Dim outputRow As Integer 

    Set sheet = Application.ActiveSheet 
    nValues = sheet.Cells.Range("E5").Value 

    Set ur = New UniqueRand 
    ur.Size = nValues 

    outputRow = 6 
    For Col = 1 To nValues 
     sheet.Cells(outputRow, Col).Value = ur.NextRand 
    Next Col 

End Sub