No recurrence random words [resolved]

Hi! :bigyello: to see if I you help me, the question is:
I have this to generate random words:
But i want those words can not be repeated ... and that's it, so simple ... :)
(Do not be scared it was dirty ;))

Code:

---

Private Sub Aleatory_Comb(ByRef CharList() As String, ByVal iDigits As Integer, ByVal iNumber As Long)
    Dim sWord As String
    Dim x    As Long
    Dim y    As Long
    For y = 1 To iNumber
        For x = 1 To iDigits
            Randomize
            sWord = sWord + CharList((Rnd * (UBound(CharList()) - 1) + 1))
        Next
        MsgBox sWord: sWord = ""
    Next
End Sub

Private Sub Form_Load()
    Dim Matriz() As String
    Matriz = Split("a,b,c,d,e,f,g,h,i,j,k,l,,m,ñ,o,p,q,r,s,t,u,v,w,x,y,z", ",")
    Call Aleatory_Comb(Matriz, 5, 7)
End Sub

---

Thanks!!:thumb:

Simply add the generated word to an array or a list, and before adding it check if it is already in there. That might get slow as the list grows, so what you can do is just keep adding them and when you're done do one pass through it and remove duplicates.

I was thinking it friend, but if the process generates 30,000 words would be very slow, do not you think?:sick:

Thanks!:thumb:

Checking each time would, but creating a list and then removing duplicates would be much much faster, if that's an option for you.

I have always like using a collection to remove duplicates

Code:

---

Private Sub Aleatory_Comb(ByRef CharList() As String, ByVal iDigits As Integer, ByVal iNumber As Long)
    Dim sWord As String
    Dim x    As Long
    Dim y    As Long
    Dim col As Collection
   
    Set col = New Collection
   
    On Error Resume Next
    Randomize
   
    Do While y < iNumber
        For x = 1 To iDigits
            Randomize
            sWord = sWord + CharList((Rnd * (UBound(CharList()) - 1) + 1))
        Next x
       
        col.Add sWord, sWord
       
        If Err.Number = 0 Then
            Debug.Print sWord
            y = y + 1
        Else
            Debug.Print "Duplicate " & sWord
            Err.Clear
        End If
       
        sWord = ""
    Loop
   
    Set col = Nothing
End Sub

---

if you add the words to a collection it will only allow each item once
use an error handler to ignore the error produced by attempting to add a duplicate

Thanks all:D

Note that a collection is super slow, since the way it prevents duplicates is the absolute slowest way possible. (It compares the new key to every key in the collection, every time.)

30k items is pretty small, though, so it'll be peppy regardless of how you do it.

OK, so what way do you advise me to check if the word already left?:)

Thanks!:wave:

If the collection is too slow, either add them in sorted order with insertion sort while ignoring dupes with a binary search, or add them all and then sort them with quicksort, kicking out the dupes once finished. Quicksort would probably be much faster depending on how many dupes you have.

PsyK

Hmm.. I wonder if this would be 26x faster ...

Before: a 1-D array ... aa1D(30000)
New idea: a 2-D array ... aa2D(26, 2000)

That is, instead of adding to a 1-D array and needing
to check a possible 30,000 entries for duplicates,
you would add to a 2-D array based on the 1st letter, as in

• a's go in aa2D(1, xxxx)
• b's go in aa2D(2, xxxx)
• ... etc.

and you'd only be checking a possible of 2,000 a's,
for example.

Thus, you will have far fewer to check for duplicates.
Granted, it won't be 26x faster, since you will probably
have fewer x, y, z words, but, I hope you get my drift.

I'd be inclined to Dim aa2D(26, 2000) at the outset,
as opposed to constantly using ReDim Preserve.

Possible alternatives:

• use 3000, or 4000 as 2nd dimension (ie, way oversized)
• do ReDim Preserve at intervals of 2000

Spoo

Here's how I'd do it:

Code:

---

Private Sub Aleatory_Comb(ByRef CharList() As String, ByVal iDigits As Integer, ByVal iNumber As Long)
    Dim sUsed As String
        Dim sWord As String
    Dim x    As Long
    Dim y    As Long
    For y = 1 To iNumber
        For x = 1 To iDigits
            Randomize
            sWord = sWord & CharList(Rnd * (UBound(CharList()) - 1) + 1)
        Next x
                If InStrB(1, sUsed, sWord & "|") = 0 Then
                        MsgBox sWord
                End If
                sUsed = sUsed & sWord & "|"
                sWord = vbNullString
    Next y
End Sub

---

Quote:

---

Originally Posted by Ellis Dee

Note that a collection is super slow, since the way it prevents duplicates is the absolute slowest way possible. (It compares the new key to every key in the collection, every time.)

---

Not true. When you add an item the Colection hashes the key, probes the hash table for a match or matches, then it compares the key against each key that hashed to the same value.

Not peppy but nowhere near as bad as comparing the new key to every existing key.

Code:

---

Private Sub Aleatory_Comb(ByRef CharList() As String, ByVal iDigits As Integer, ByVal iNumber As Long)
    Dim sUsed As String
        Dim sWord As String
    Dim x    As Long
    Dim y    As Long
    For y = 1 To iNumber
        For x = 1 To iDigits
            Randomize
            sWord = sWord & CharList(Rnd * (UBound(CharList()) - 1) + 1)
        Next x
                If InStrB(1, sUsed, sWord & "|") = 0 Then
                        MsgBox sWord
                End If
                sUsed = sUsed & sWord & "|"
                sWord = vbNullString
    Next y
End Sub

---

@Zach_VB6:
Thanks but Im afraid this code dosen´t works becouse if i put in the call this:

Code:

---

    Dim Matriz() As String
    Matriz = Split("a,b,c", ",")
    Call Aleatory_Comb(Matriz, 3, 1000)

---

it should return me 1000 words, but I only returned 8 ... What is the problem?
Regarding the solutions have been giving me, for now convinces me most is to keep everything in a list, and then delete duplicates, so I never have to check every time, and I think it would save much time ... but I would not know removed the repeated elements in the collection ... what is your opinion on this? :confused:

Thank you very much :wave:

Quote:

---

it should return me 1000 words, but I only returned 8 ... What is the problem?

---

With 3 characters, you can build maximum of 27 different words with length of 3 (3³ = 27). You cannot expect 1000 words.
Change this line:
sWord = sWord & CharList(Rnd * (UBound(CharList()) - 1) + 1)
to this:
sWord = sWord & CharList(Int(Rnd * (UBound(CharList) + 1)))
You will have 27 words.

Randomize should be called only once.
-----------------------

Try the code below:

Code:

---

Option Explicit

Function RandWords(sCharsUsed As String, iLen As Long, ByVal iMax As Long) As String()
    If Len(sCharsUsed) = 0 Or iLen < 1 Or iMax < 1 Then
        RandWords = Split("") '-- return an array with Ubound = -1
        Exit Function
    End If
   
    Dim WordList() As String, sWord As String, ch As String, sChars As String
    Dim w As Long, n As Long, i As Long, j As Long, Count As Long
    Dim p As Variant
       
    Randomize
   
    '-- check to make sure sCharsUsed contains no duplicate characters
    For i = 1 To Len(sCharsUsed)
        If InStr(Mid$(sCharsUsed, i + 1), Mid$(sCharsUsed, i, 1)) = 0 Then
            sChars = sChars & Mid$(sCharsUsed, i, 1)
        End If
    Next
       
    n = Len(sChars)
    p = CDec(n) ^ iLen
   
    If iMax > p Then iMax = p
    ReDim WordList(1 To n)
   
    Do While Count < iMax
        sWord = Space$(iLen)
        w = 1 + Int(Rnd() * n)
        Mid$(sWord, 1, 1) = Mid$(sChars, w, 1)
        For i = 2 To iLen
            j = 1 + Int(Rnd() * n)
            Mid$(sWord, i, 1) = Mid$(sChars, j, 1)
        Next
        If InStrB(WordList(w), sWord) = 0 Then
            WordList(w) = WordList(w) & "|" & sWord
            Count = Count + 1
        End If
    Loop
    RandWords = Split(Mid(Join(WordList, ""), 2), "|")
    Erase WordList
End Function

---

Code:

---

Sub BuildWords()
    Dim Words() As String
    Dim sChars As String
    Dim iLen As Long
    Dim iMax As Long
    Dim w As Long
    Dim i As Long
    Dim t As Single

    sChars = "abcdefghijklmnopqrstuvwxyz"
    iLen = 8
    iMax = 30000
   
    t = Timer
    Words = RandWords(sChars, iLen, iMax)
    t = Timer - t
   
    w = UBound(Words)
    '--- if you want to print all words, uncomment the ForNext block below
    'For i = 0 To w
    '    Debug.Print Words(i); " ";
    '    If i Mod 16 = 15 Then Debug.Print
    'Next
    Debug.Print
    Debug.Print "sChars = """; sChars; """"
    Debug.Print "iLen ="; iLen
    Debug.Print "iMax ="; iMax
    Debug.Print "Possible words  ="; Len(sChars); "^"; iLen; "= "; CDec(Len(sChars)) ^ iLen
    Debug.Print "Generated words = "; w + 1
    Debug.Print t; " seconds"
End Sub

---

Code:

---

sChars = "abcdefghijklmnopqrstuvwxyz"
iLen = 8
iMax = 30000
Possible words  = 26 ^ 8 =  208827064576
Generated words =  30000
 1.75  seconds

---

Wow, thanks Im learning a lot with you!!
I have another question:
I put a progress bar to show me what I have to stop generating words, I do that and I do not work ...

Code:

---

Private Sub Aleatory_Comb(ByRef CharList() As String, ByVal iDigits As Integer, ByVal iNumber As Long)
    Dim sWord As String
    Dim x    As Long
    Dim y    As Long
    Dim col As Collection
   
    Set col = New Collection
    PB.Max = iNumber
    On Error Resume Next
    Randomize
   
    Do While y < iNumber
        For x = 1 To iDigits
            Randomize
            sWord = sWord + CharList((Rnd * (UBound(CharList()) - 1) + 1))
        Next x
       
        col.Add sWord, sWord
       
        If Err.Number = 0 Then
            Debug.Print sWord : PB.Value = PB.Value + 1: Doevents
            y = y + 1
        Else
            Debug.Print "Duplicate " & sWord
            Err.Clear
        End If
       
        sWord = ""
    Loop

---

The progress bar does not move ... (I make the call from a button, not the From_Load)
Why? :confused:

Thanks :afrog:

try

Code:

---

        If Err.Number = 0 Then
            Debug.Print sWord
            y = y + 1
            PB.Value = y
        Else
            Debug.Print "Duplicate " & sWord
            Err.Clear
        End If

---

OK thaks men!!!!!!!!!!!!!!!!!!!!!!!!!!!!:afrog:
It works!

I considered settled this thread:thumb:

As you now have it sorted out, could you please do us a little favour, and mark the thread as Resolved?
(this saves time reading for those of us who like to answer questions, and also helps those who search to find answers)

You can do it by clicking on "Thread tools" just above the first post in this thread, then "Mark thread resolved". (like various other features of this site, you need JavaScript enabled in your browser for this to work).