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
 

Some videos you may like

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.

JoeMo

MrExcel MVP
Joined
May 26, 2009
Messages
17,388
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
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:

gsimmons

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

MrExcel MVP
Joined
May 26, 2009
Messages
17,388
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
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

MrExcel MVP
Joined
Apr 18, 2011
Messages
36,686
Office Version
  1. 2010
Platform
  1. Windows

ADVERTISEMENT

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
 

JoeMo

MrExcel MVP
Joined
May 26, 2009
Messages
17,388
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
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
 

Watch MrExcel Video

Forum statistics

Threads
1,122,628
Messages
5,597,247
Members
414,133
Latest member
lucid33

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
Top