Home » excel » Generating a list of random words in Excel, but no duplicates

Generating a list of random words in Excel, but no duplicates

Posted by: admin May 14, 2020 Leave a comment

Questions:

I’m trying to generate words in Column B from a list of given words in Column A.

Right now my code in Excel VBA does this:

Function GetText()
    Dim GivenWords
    GivenWords = Sheets(1).Range(Sheets(1).[a1], Sheets(1).[a20])
    GetText = A(Application.RandBetween(1, UBound(A)), 1)
End Function

This generates a word from the list I have provided in A1:A20, but I don’t want any duplicates.

GetText() will be run 15 times in Column B from B1:B15.

How can I check for any duplicates in Column B, or more efficiently, remove the words temporarily from the list once it has been used?

For example,

  1. Select Range A1:A20
  2. Select one value randomly (e.g A5)
  3. A5 is in Column B1
  4. Select Range A1:A4 and A6:A20
  5. Select one value randomly (e.g A7)
  6. A7 is in Column B2
  7. Repeat, etc.
How to&Answers:

This was trickier than I thought. The formula should be used as a vertical array eg. select the cells where you want the output, press f2 type =gettext(A1:A20) and press ctrl+shift+enter

This means that you can select where your input words are in the worksheet, and the output can be upto as long as that list of inputs, at which point you’ll start getting #N/A errors.

Function GetText(GivenWords as range)
    Dim item As Variant
    Dim list As New Collection
    Dim Aoutput() As Variant
    Dim tempIndex As Integer
    Dim x As Integer

    ReDim Aoutput(GivenWords.Count - 1) As Variant
    For Each item In GivenWords
        list.Add (item.Value)
    Next
    For x = 0 To GivenWords.Count - 1
        tempIndex = Int(Rnd() * list.Count + 1)
        Aoutput(x) = list(tempIndex)
        list.Remove tempIndex
    Next

    GetText = Application.WorksheetFunction.Transpose(Aoutput())
End Function

Answer:

Here’s how I would do it, using 2 extra columns, and no VBA code…

A              B        C                    D
List of words  Rand     Rank                 15 Words
Apple          =RAND()  =RANK(B2,$B$2:$B$21) =INDEX($A$2:$A$21,MATCH(ROW()-1,$C$2:$C$21,0))

copy B2 and C2 down as far as the list, and drag D down for however many words you want.

Copy the word list somewhere, as every time you change something on the sheet (or recalculate), you will get a new list of words

Example

Using VBA:

Sub GetWords()
Dim Words
Dim Used(20) As Boolean
Dim NumChosen As Integer
Dim RandWord As Integer

Words = [A1:A20]

NumChosen = 0

While NumChosen < 15
    RandWord = Int(Rnd * 20) + 1
    If Not Used(RandWord) Then
        NumChosen = NumChosen + 1
        Used(RandWord) = True
        Cells(NumChosen, 2) = Words(RandWord, 1)
    End If
Wend
End Sub

Answer:

Here is the code. I am deleting the cell after using it. Please make a backup of your data before using this as it will delete the cell contents (it will not save automatically…but just in case). You need to run the ‘main’ sub to get the output.

Sub main()
  Dim i As Integer
  'as you have put 15 in your question, i am using 15 here. Change it as per your need.
   For i = 15 To 1 Step -1
     'putting the value of the function in column b (upwards)
     Sheets(1).Cells(i, 2).Value = GetText(i)
   Next
End Sub

Function GetText(noofrows As Integer)
  'if noofrows is 1, the rand function wont work
   If noofrows > 1 Then
     Dim GivenWords
     Dim rowused As Integer
     GivenWords = Sheets(1).Range(Sheets(1).Range("A1"), Sheets(1).Range("A" & noofrows))

    'getting the randbetween value to a variable bcause after taking the value, we can delete the cell.
     rowused = (Application.RandBetween(1, UBound(GivenWords)))
     GetText = Sheets(1).Range("A" & rowused)

     Application.DisplayAlerts = False
     'deleting the cell as we have used it and the function should not use it again
     Sheets(1).Cells(rowused, 1).Delete (xlUp)
     Application.DisplayAlerts = True
   Else
    'if noofrows is 1, there is only one value left. so we just use it.
    GetText = Sheets(1).Range("A1").Value
    Sheets(1).Cells(1, 1).Delete (xlUp)
   End If
End Function

Hope this helps.