wjshore
asked on
Take out the dupes
The following bit of VB6 code is supposed to produce a list of values for the variables M1 thru M20. The numbers should be 0 thru 19 in random order. Yet it now gives several sets of duplicate numbers. Can anyone see how this needs to be changed so that no duplicates are produced?
Public Sub ChooseRandomScreens()
'Select 20 Title screen positions at random
Dim iScreens(19) As Double
Dim i As Integer
Dim j As Integer
Dim iTest As Integer
Dim ListLength As Integer
Dim bFound As Boolean
' ListLength = number of Form1.Title() screens
ListLength = 20
For i = 0 To 19
bFound = False
Do
iTest = 1 + Int(Rnd * ListLength)
For j = 0 To i - 1
If iTest = Rnd(i) Then
bFound = True
Exit For
End If
Next j
Loop Until bFound = False
iScreens(i) = iTest
Next i
M1 = iScreens(0)
M2 = iScreens(1)
M3 = iScreens(2)
M4 = iScreens(3)
M5 = iScreens(4)
M6 = iScreens(5)
M7 = iScreens(6)
M8 = iScreens(7)
M9 = iScreens(8)
M10 = iScreens(9)
M11 = iScreens(10)
M12 = iScreens(11)
M13 = iScreens(12)
M14 = iScreens(13)
M15 = iScreens(14)
M16 = iScreens(15)
M17 = iScreens(16)
M18 = iScreens(17)
M19 = iScreens(18)
M20 = iScreens(19)
End Sub
Public Sub ChooseRandomScreens()
'Select 20 Title screen positions at random
Dim iScreens(19) As Double
Dim i As Integer
Dim j As Integer
Dim iTest As Integer
Dim ListLength As Integer
Dim bFound As Boolean
' ListLength = number of Form1.Title() screens
ListLength = 20
For i = 0 To 19
bFound = False
Do
iTest = 1 + Int(Rnd * ListLength)
For j = 0 To i - 1
If iTest = Rnd(i) Then
bFound = True
Exit For
End If
Next j
Loop Until bFound = False
iScreens(i) = iTest
Next i
M1 = iScreens(0)
M2 = iScreens(1)
M3 = iScreens(2)
M4 = iScreens(3)
M5 = iScreens(4)
M6 = iScreens(5)
M7 = iScreens(6)
M8 = iScreens(7)
M9 = iScreens(8)
M10 = iScreens(9)
M11 = iScreens(10)
M12 = iScreens(11)
M13 = iScreens(12)
M14 = iScreens(13)
M15 = iScreens(14)
M16 = iScreens(15)
M17 = iScreens(16)
M18 = iScreens(17)
M19 = iScreens(18)
M20 = iScreens(19)
End Sub
Hello wjshore,
Public Sub ChooseRandomScreens()
'Select 20 Title screen positions at random
Dim iScreens(19) As Double
Dim coll As Collection
Dim Counter As Long
Dim Grab As Long
Set coll = New Collection
For Counter = 0 To 19
Coll.Add Counter
Next
Randomize
For Counter = 0 To 19
Grab = Int(Rnd * coll.Count)
iScreens(Counter) = coll(Grab)
coll.Remove Grab
Next
Set coll = Nothing
M1 = iScreens(0)
M2 = iScreens(1)
M3 = iScreens(2)
M4 = iScreens(3)
M5 = iScreens(4)
M6 = iScreens(5)
M7 = iScreens(6)
M8 = iScreens(7)
M9 = iScreens(8)
M10 = iScreens(9)
M11 = iScreens(10)
M12 = iScreens(11)
M13 = iScreens(12)
M14 = iScreens(13)
M15 = iScreens(14)
M16 = iScreens(15)
M17 = iScreens(16)
M18 = iScreens(17)
M19 = iScreens(18)
M20 = iScreens(19)
End Sub
Regards,
Patrick
Public Sub ChooseRandomScreens()
'Select 20 Title screen positions at random
Dim iScreens(19) As Double
Dim coll As Collection
Dim Counter As Long
Dim Grab As Long
Set coll = New Collection
For Counter = 0 To 19
Coll.Add Counter
Next
Randomize
For Counter = 0 To 19
Grab = Int(Rnd * coll.Count)
iScreens(Counter) = coll(Grab)
coll.Remove Grab
Next
Set coll = Nothing
M1 = iScreens(0)
M2 = iScreens(1)
M3 = iScreens(2)
M4 = iScreens(3)
M5 = iScreens(4)
M6 = iScreens(5)
M7 = iScreens(6)
M8 = iScreens(7)
M9 = iScreens(8)
M10 = iScreens(9)
M11 = iScreens(10)
M12 = iScreens(11)
M13 = iScreens(12)
M14 = iScreens(13)
M15 = iScreens(14)
M16 = iScreens(15)
M17 = iScreens(16)
M18 = iScreens(17)
M19 = iScreens(18)
M20 = iScreens(19)
End Sub
Regards,
Patrick
ASKER
Thanks, Jim. Randomize should be there, but it produces the same dupe-contaminated results.
ASKER
Patrick, again thanks for contributing. When I run your code, I get "script out of range" error at
iScreens(Counter) = coll(Grab)
Can you see the problem? Thanks.
iScreens(Counter) = coll(Grab)
Can you see the problem? Thanks.
Things seem to have got a bit muddled.
This is your code re-arranged
Public Sub ChooseRandomScreens()
'Select 20 Title screen positions at random
Dim iScreens(19) As Double
Dim i As Integer
Dim j As Integer
Dim iTest As Integer
Dim ListLength As Integer
Dim bFound As Boolean
' ListLength = number of Form1.Title() screens
ListLength = 20
For i = 0 To 19
Do
bFound = False
iTest = 1 + Int(Rnd * ListLength)
For j = 0 To i - 1
If iTest = iScreens(j) Then
bFound = True
Exit For
End If
Next j
Loop Until bFound = False
iScreens(i) = iTest
Next i
This is your code re-arranged
Public Sub ChooseRandomScreens()
'Select 20 Title screen positions at random
Dim iScreens(19) As Double
Dim i As Integer
Dim j As Integer
Dim iTest As Integer
Dim ListLength As Integer
Dim bFound As Boolean
' ListLength = number of Form1.Title() screens
ListLength = 20
For i = 0 To 19
Do
bFound = False
iTest = 1 + Int(Rnd * ListLength)
For j = 0 To i - 1
If iTest = iScreens(j) Then
bFound = True
Exit For
End If
Next j
Loop Until bFound = False
iScreens(i) = iTest
Next i
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
GrahamSkan: Eureka! Dupes gone. The routine produces numbers from 1 to 20. Which is the right line to tweek to produce 0 to 19? Thanks.
ASKER
Thank you Graham and Patrick!! When I removed the '1+' from Graham's ' iTest = 1 + Int(Rnd * ListLength)', both solutions worked equally well.
How about something like?
' -------------------------
' Form1
' -------------------------
Option Explicit
Public M1 As Integer
Public M2 As Integer
Public M3 As Integer
Public M4 As Integer
Public M5 As Integer
Public M6 As Integer
Public M7 As Integer
Public M8 As Integer
Public M9 As Integer
Public M10 As Integer
Public M11 As Integer
Public M12 As Integer
Public M13 As Integer
Public M14 As Integer
Public M15 As Integer
Public M16 As Integer
Public M17 As Integer
Public M18 As Integer
Public M19 As Integer
Public M20 As Integer
Private Sub Command1_Click()
ChooseRandomScreens
End Sub
Private Sub ChooseRandomScreens()
Static randomized As Boolean
If Not randomized Then
Debug.Print "Randomizing"
Randomize
randomized = True
End If
Dim i As Integer
Dim arrNumbers() As Integer
arrNumbers = generateSet(0, 19, 20)
For i = 1 To 20
CallByName Me, "M" & i, VbLet, arrNumbers(i - 1)
Next i
For i = 1 To 20
Debug.Print "M" & i & " = " & CallByName(Me, "M" & i, VbGet)
Next i
End Sub
Private Function generateSet(ByVal rangeMin As Integer, ByVal rangeMax As Integer, ByVal setSize As Integer) As Integer()
Dim rangesize As Integer
Dim rangeSet() As Integer
Dim i As Integer
Dim r As Byte
Dim swapWith As Integer
Dim tempInt As Integer
' compute the size of the range
rangesize = rangeMax - rangeMin + 1
' make sure the input parameters make sense...
If rangeMax < rangeMin Then
MsgBox "rangeMax must be greater than or equal to rangeMin"
Exit Function
End If
If setSize <= 0 Or setSize > rangesize Then
MsgBox "setsize must be greater than zero and less than or equal to the range size"
Exit Function
End If
' resize our array
ReDim rangeSet(rangesize - 1)
' build the range set
For i = 0 To rangesize - 1
rangeSet(i) = i + rangeMin
Next i
' shuffle the range set 7 times
For r = 1 To 7
' for each item in the set,
' pick another item and
' swap them
For i = 0 To rangesize - 1
swapWith = Int(rangesize * Rnd)
tempInt = rangeSet(i)
rangeSet(i) = rangeSet(swapWith)
rangeSet(swapWith) = tempInt
Next i
Next r
' return the selected set (first setSize elements)
ReDim Preserve rangeSet(setSize - 1)
generateSet = rangeSet
End Function
' -------------------------
' Form1
' -------------------------
Option Explicit
Public M1 As Integer
Public M2 As Integer
Public M3 As Integer
Public M4 As Integer
Public M5 As Integer
Public M6 As Integer
Public M7 As Integer
Public M8 As Integer
Public M9 As Integer
Public M10 As Integer
Public M11 As Integer
Public M12 As Integer
Public M13 As Integer
Public M14 As Integer
Public M15 As Integer
Public M16 As Integer
Public M17 As Integer
Public M18 As Integer
Public M19 As Integer
Public M20 As Integer
Private Sub Command1_Click()
ChooseRandomScreens
End Sub
Private Sub ChooseRandomScreens()
Static randomized As Boolean
If Not randomized Then
Debug.Print "Randomizing"
Randomize
randomized = True
End If
Dim i As Integer
Dim arrNumbers() As Integer
arrNumbers = generateSet(0, 19, 20)
For i = 1 To 20
CallByName Me, "M" & i, VbLet, arrNumbers(i - 1)
Next i
For i = 1 To 20
Debug.Print "M" & i & " = " & CallByName(Me, "M" & i, VbGet)
Next i
End Sub
Private Function generateSet(ByVal rangeMin As Integer, ByVal rangeMax As Integer, ByVal setSize As Integer) As Integer()
Dim rangesize As Integer
Dim rangeSet() As Integer
Dim i As Integer
Dim r As Byte
Dim swapWith As Integer
Dim tempInt As Integer
' compute the size of the range
rangesize = rangeMax - rangeMin + 1
' make sure the input parameters make sense...
If rangeMax < rangeMin Then
MsgBox "rangeMax must be greater than or equal to rangeMin"
Exit Function
End If
If setSize <= 0 Or setSize > rangesize Then
MsgBox "setsize must be greater than zero and less than or equal to the range size"
Exit Function
End If
' resize our array
ReDim rangeSet(rangesize - 1)
' build the range set
For i = 0 To rangesize - 1
rangeSet(i) = i + rangeMin
Next i
' shuffle the range set 7 times
For r = 1 To 7
' for each item in the set,
' pick another item and
' swap them
For i = 0 To rangesize - 1
swapWith = Int(rangesize * Rnd)
tempInt = rangeSet(i)
rangeSet(i) = rangeSet(swapWith)
rangeSet(swapWith) = tempInt
Next i
Next r
' return the selected set (first setSize elements)
ReDim Preserve rangeSet(setSize - 1)
generateSet = rangeSet
End Function
By the way, my generateSet() function above would work well for your previous question:
Dim arrNumbers() As Integer
arrNumbers = generateSet(1, 20, 4) ' pick four numbers from 1 to 20
Dim arrNumbers() As Integer
arrNumbers = generateSet(1, 20, 4) ' pick four numbers from 1 to 20
Public Sub ChooseRandomScreens()
Randomize
'The rest of your code goes here
End Sub