Generate random numbers with multiple conditional statements?

[gsimmons]

Help (Please!),

I'm trying to randomly generate thirteen "Distractors" (single-digit numerals ranging from 2 to 8).

However, the randomization must be subject to the condition that each new Distractor ("i") has not appeared as one of the previous three distractors (that is "i - 1", "i - 2", "i - 3")

Also, it would be ideal if all 7 digits were used once before they started recycling, though this isn't critical and I haven't even started on it in the code below.

Here's my code- I'm certainly not married to it. Any help is appreciated.

-- Greg

* I'm working on Windows XP (code must also work on Windows 7 eventually) and Excel 2007

Sub Random_Distractor()
'
' Random_Distractor Macro
'

'
    Dim i As Integer
    Dim Cellname, PrevCellname, PrevTwoCellname, PrevThreeCellname As String
    
    
    For i = 1 To 13
    
    Cellname = "E" & "i"
    Range("Cellname").Activate
    ActiveCell.FormulaR1C1 = "=RANDBETWEEN(2,8)"
    PrevCellname = "E" & "(i - 1)"
    PrevTwoCellname = "E" & "(i - 2)"
    PrevThreeCellname = "E" & "(i - 3)"
    
    If i > 1 Then
      Do
      If ActiveCell.Value = Range(PrevCellname).Value Then
      ActiveCell.FormulaR1C1 = "=RandBetween(2,8)"
      End If
      Loop Until ActiveCell.Value <> Range(PrevCellname).Value
    End If
        
    If i > 2 Then
      Do
      If ActiveCell.Value = Range(PrevCellname).Value Or ActiveCell.Value = Range(PrevTwoCellname).Value Then
      ActiveCell.FormulaR1C1 = "=RandBetween(2,8)"
      End If
      Loop Until ActiveCell.Value <> Range(PrevCellname).Value And ActiveCell.Value <> Range(PrevTwoCellname).Value
    End If
        
    If i > 3 Then
      Do
      If ActiveCell.Value = Range(PrevCellname).Value Or ActiveCell.Value = Range(PrevTwoCellname).Value Or ActiveCell.Value = Range(PrevThreeCellname).Value Then
      ActiveCell.FormulaR1C1 = "=RandBetween(2,8)"
      End If
      Loop Until ActiveCell.Value <> Range(PrevCellname).Value And ActiveCell.Value <> Range(PrevTwoCellname).Value And ActiveCell.Value <> Range(PrevThreeCellname).Value
    End If
             
    Next i
    
     
    Range(Cellname).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    End Sub

 

[JoeMo]

Try this - the first 7 of 13 will have no repeats, the balance will adhere to the no repeat of prior three rule. To run this, select a cell and enter "Distractors", then Formula/Define Range so that the cell is the named range "Distractors". The 13 random values will list out under this cell.

Sub Distractors13()
Dim d As Object, R As Range, ct As Long, Num As Long, prev3(0 To 2) As Long, b As Variant, x As Long
Const s As Long = 2
Const e As Long = 8
Set R = Range("Distractors")
Set d = CreateObject("Scripting.dictionary")
d.RemoveAll
'First 7 no repeats
Do
    Num = WorksheetFunction.RandBetween(s, e)
    If Not d.exists(Num) Then
        ct = ct + 1
        d.Add Num, ct
    End If
Loop Until ct = 7
b = d.keys
R.Offset(1, 0).Resize(ct, 1).Value = Application.Transpose(d.keys)
'Next 6
For i = 0 To 2
    prev3(i) = b(6 - i)
Next i
Do
    Num = WorksheetFunction.RandBetween(s, e)
    For i = 0 To 2
        If Num = prev3(i) Then
            x = 0
            Exit For
        Else
            x = x + 1
            If x >= 3 Then
                ct = ct + 1
                R.Offset(ct, 0).Value = Num
                prev3(2) = Num
                x = 0
                Exit For
            End If
        End If
    Next i
Loop Until ct = 13
End Sub

 

[gsimmons]

JoeMo,

Thanks for your help, that certainly got the first part (1-7). Unfortunately, 8-13 are not quite obeying, at least not on my machine.

Specifically, I'm getting repeats of (i - 2) and (i - 3). There were no repetitions of (i - 1) in the six trials I ran.

Also, if it helps, the repetitions only occur within the 8-13 set. They never seem to "reach across" and repeat the end of the 1-7 set.

A sincere thanks for your help.

-- Greg

 

[JoeMo]

JoeMo,

Thanks for your help, that certainly got the first part (1-7). Unfortunately, 8-13 are not quite obeying, at least not on my machine.

Specifically, I'm getting repeats of (i - 2) and (i - 3). There were no repetitions of (i - 1) in the six trials I ran.

Also, if it helps, the repetitions only occur within the 8-13 set. They never seem to "reach across" and repeat the end of the 1-7 set.

A sincere thanks for your help.

-- Greg

Just got to your reply and it's past my bedtime. I'll try to provide a fix in the morning.

 

[Rick Rothstein]

See if this code does what you want...

Sub SpecialRandomNumbers()
  Dim X As Long, Z As Long, Counter As Long, RandomIndex As Long, Tmp As Long, Numbers() As Long
  Static AlreadyRandomized As Boolean
  If Not AlreadyRandomized Then
    AlreadyRandomized = True
    Randomize
  End If
  ReDim Numbers(1 To 7)
  For X = 2 To 8
    Numbers(X - 1) = X
  Next
  For X = UBound(Numbers) To LBound(Numbers) Step -1
     RandomIndex = Int(X * Rnd + 1)
     Tmp = Numbers(RandomIndex)
     Numbers(RandomIndex) = Numbers(X)
     Numbers(X) = Tmp
  Next
  Range("E1:E7") = WorksheetFunction.Transpose(Numbers)
  ReDim Numbers(1 To 4)
  For Z = 8 To 13
    Counter = 0
    For X = 2 To 8
      If Cells(Z - 1, "E").Value <> X And Cells(Z - 2, "E").Value <> X And Cells(Z - 3, "E").Value <> X Then
        Counter = Counter + 1
        Numbers(Counter) = X
      End If
    Next
    Cells(Z, "E").Value = Numbers(Int(4 * Rnd) + 1)
  Next
End Sub

 

[gsimmons]

Success! That's done it, many thanks to both of you. -- Greg

 

[JoeMo]

Success! That's done it, many thanks to both of you. -- Greg

Glad you got a solution from Rick, but for the record I corrected the code I posted (and this time I tested it!). Should provide an alternative solution.

Sub Distractors13()
Dim d As Object, R As Range, ct As Long, Num As Long, prev3(0 To 2) As Long, b As Variant, x As Long
Const s As Long = 2
Const e As Long = 8
Set R = Range("Distractors")
Set d = CreateObject("Scripting.dictionary")
d.RemoveAll
'First 7 no repeats
Do
    Num = WorksheetFunction.RandBetween(s, e)
    If Not d.exists(Num) Then
        ct = ct + 1
        d.Add Num, ct
    End If
Loop Until ct = 7
b = d.keys
R.Offset(1, 0).Resize(ct, 1).Value = Application.Transpose(d.keys)
'Next 6
For i = 0 To 2
    prev3(i) = b(6 - i)
Next i
Do
    Num = WorksheetFunction.RandBetween(s, e)
    For i = 0 To 2
        If Num = prev3(i) Then
            x = 0
            Exit For
        Else
            x = x + 1
            If x >= 3 Then
                ct = ct + 1
                R.Offset(ct, 0).Value = Num
                prev3(2) = prev3(1)
                prev3(1) = prev3(0)
                prev3(0) = Num
                x = 0
                Exit For
            End If
        End If
    Next i
Loop Until ct = 13
End Sub