VBA-Excel / How to randomly pick up a word from a dictionary?

Question

Lets say I have a database of words in Sheet2; it goes from A1 to B200.

I need to randomly select one of those words; and show it in Sheet1.

Moreover, I need to have on blank cell between each letter of the word.

Example: The randomly selected word is COLD; it has to appear like this:

A1: C

A3: O

A5: L

A7: D

How can I code this?

Answer 1

try this code:

Option Explicit

Sub main()
    Dim word As String

    word = GetRandomWord(Worksheets("Sheet2").Range("A1:B200")) '<--| get content of a random cell in passed range
    Worksheets("Sheet1").Range("a1").Resize(2 * Len(word) - 1).Value = Application.Transpose(SeparatedChars(word)) '<--| write it down from given worksheet cell A1 down skipping every two cells
End Sub

Function SeparatedChars(strng As String) As Variant
    Dim i As Long

    ReDim chars(0 To Len(strng) - 1) As String '<--| size a 'String' array to the length of passed word
    For i = 1 To Len(strng)
        chars(i - 1) = Mid$(strng, i, 1) '<--| fill array elements with word single characters
    Next
    SeparatedChars = Split(Join(chars, "  "), " ") '<--| return an array whose elements are those of the 'String' array and interposed spaces
End Function

Function GetRandomWord(rng As Range) As String
    Randomize
    GetRandomWord = rng.Cells(Int((rng.Count) * Rnd() + 1)).Text
End Function

Answer 2

Assuming the words are written in column A of sheet2 you could do the following (part of this solution comes from here:

Sub randomWord()
Dim rndWordRow As Integer
Dim arr() As String
Dim buff() As String

'Select row between 1 and 200 randomly'
rndWordRow = Int((200 - 1 + 1) * Rnd + 1)

'Write text of the randomly selected row into variable'
rndWord = Sheets("Sheet2").Cells(rndWordRow, 1)

'Write letters of text into array'
ReDim buff(Len(rndWord) - 1)
For i = 1 To Len(rndWord)
    buff(i - 1) = Mid$(rndWord, i, 1)
Next

'Loop through array and write letters in single cells'
For i = 0 To UBound(buff)
    Sheets("Sheet1").Cells(i + 1, 1) = buff(i)
Next i

End Sub

Answer 3

---

Sub Test()
    Dim x As Long
    Dim aWord
    With Worksheets("Sheet1")
        For x = 1 To 15
            aWord = getRandomWord
            .Cells(1, x).Resize(UBound(aWord)).value = aWord
        Next

    End With
End Sub

Function getRandomWord()
    Dim Source As Range
    Dim result
    Dim i As Integer
    Set Source = Worksheets("Sheet2").Range("A1:B200")

    i = Int((Rnd * Source.Cells.Count) + 1)
    result = StrConv(Source.Cells(i).Text, vbUnicode)
    result = Split(Left(result, Len(result) - 1), vbNullChar)
    getRandomWord = Application.Transpose(result)
End Function

Answer 4

Here's a simple solution to your problem. This routine gives you a blank cell between two letters with the first letter in the first cell.

R1 = Int(Rnd() * 200)
R2 = Int(Rnd() * 2)

anyword = Sheet2.Cells(R1, R2)
x = Len(anyword)
n = -1: i = 1
Do
   n = n + 2
   Sheet1.Cells(n, 1) = Mid(anyword, i, 1)
   i = i + 1

Loop Until n > x * 2