Generate random numbers with multiple conditional statements?

gsimmons

New Member
Joined
Feb 18, 2013
Messages
3
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

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

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).
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.
Code:
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
 
Last edited:
Upvote 0
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
 
Upvote 0
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.
 
Upvote 0
See if this code does what you want...
Code:
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
 
Upvote 0
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.
Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,544
Messages
6,114,239
Members
448,555
Latest member
RobertJones1986

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top