Draw words from a list without duplicates

T

Tim

We have a game like bingo but it uses words and not numbers, thought it
would be great if we could pick the words using excel. I have seen a sheet
that was used to draw numbers for Bingo, see code below, so my question is
can excel pick a random word or phrase without duplicates, and list them on
a sheet and then pick another one?


Here are the details.

The words or phrase are in sheet2 A1:A??? right now it is A50 but could be
more or less, It would need to pick a word from the list when a button is
clicked and put that word in lets say sheet1 A1, the next time it is clicked
it would need to pick a different word from the list and put it in sheet1 A2
an so on....

We would need someway to set the range in VBA if more words are added or
subtracted, ideally it would somehow "know" how many words were in sheet2
column A and adjust to that, don't even know if that is possible.

I have excel 2002

The code below may give you a better understanding of what I want to do.

If you run set_up_sheet it will set the sheet up like it needs to be then
just click on the draw button it see how it works, there is also a macro to
clear the sheet., clear_numbers.

I want it to work like this but to draw words from sheet2 A1 down



Option Explicit

Public Lottery As Variant

Public LotteryIndex As Long

Dim irow As Integer

Dim jcol As Integer

'Based on code by Tom Ogilvy 2002

'[slighty adapted by Max 2005)

Sub Clear_Numbers()

Dim msg, title, response As String

'clears the old numbers in draw mumbers sheet

msg = "Are You Sure You Want To Reset The Numbers ?"

title = "Continue ?"

response = MsgBox(msg, vbYesNo + vbQuestion, title)

If response = vbNo Then

Exit Sub ' Quit the macro

End If

Application.ScreenUpdating = False

Lottery = Shuffle()

LotteryIndex = LBound(Lottery)

irow = 2

jcol = 7

Cells(irow, jcol).CurrentRegion.ClearContents

Range("P3").Value = ""

Range("Q4").Select

Application.ScreenUpdating = True

End Sub


Private Sub InitLottery()

Lottery = Shuffle()

LotteryIndex = LBound(Lottery)

irow = 2

jcol = 7

Cells(irow, jcol).CurrentRegion.ClearContents

Range("P3").Value = ""

Range("Q4").Select

End Sub


Private Sub Draw4()

Dim vArr

Dim iMyNumber As Integer

Dim i As Byte



'draws the numbers



If Not IsArray(Lottery) Then

InitLottery

End If

If LotteryIndex > UBound(Lottery) Then

InitLottery

Cells(irow, jcol).CurrentRegion.ClearContents

End If

Range("P3").Formula = "=RandBetween(1,75)"

For i = 1 To 5

Application.Calculate

Next i

Range("P3").Value = Lottery(LotteryIndex)

Cells(irow, jcol).Value = Range("P3").Value

LotteryIndex = LotteryIndex + 1

irow = irow + 1

If irow = 12 Then

irow = 2

jcol = jcol + 1

End If



End Sub



Function Shuffle()

'

' Algorithm from:

' The Art of Computer Programming: _

' SemiNumerical Algorithms Vol 2, 2nd Ed.

' Donald Knuth

' p. 139

'

'

Dim List() As Long

Dim t As Long

Dim i As Long

Dim j As Long

Dim k As Long

Dim lngTemp As Long

Dim lbnd, ubnd As String

t = 100

lbnd = 1

ubnd = 75

t = ubnd - lbnd + 1

ReDim List(1 To t)

For i = 1 To t

List(i) = i + lbnd - 1

Next

j = t

Randomize

For i = 1 To t

k = Rnd() * j + 1

lngTemp = List(j)

List(j) = List(k)

List(k) = lngTemp

j = j - 1

Next

Shuffle = List

End Function


Sub Set_Up_Sheet()

'used to set the sheet up for demonstrating

Application.ScreenUpdating = False

Columns("G:N").Select

Selection.ColumnWidth = 3

Range("P5:Q8").Select

With Selection

.HorizontalAlignment = xlGeneral

.VerticalAlignment = xlBottom

.WrapText = False

.Orientation = 0

.AddIndent = False

.IndentLevel = 0

.ShrinkToFit = False

.ReadingOrder = xlContext

.MergeCells = True

End With

Selection.UnMerge

With Selection

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlBottom

.WrapText = False

.Orientation = 0

.AddIndent = False

.IndentLevel = 0

.ShrinkToFit = False

.ReadingOrder = xlContext

.MergeCells = False

End With

Selection.Merge

ActiveCell.FormulaR1C1 = _

"=IF(R[-2]C<1,"""",LOOKUP(R[-2]C,{0;16;31;46;61}," & _

"{""B"";""I"";""N"";""G"";""O""}))&"" ""&R[-2]C"

Range("P9").Select

Range("P5:Q8").Select

With Selection.Font

.Name = "Arial"

.Size = 26

.Strikethrough = False

.Superscript = False

.Subscript = False

.OutlineFont = False

.Shadow = False

.Underline = xlUnderlineStyleNone

.ColorIndex = xlAutomatic

End With

Selection.Font.Bold = True

ActiveSheet.Buttons.Add(90, 32, 150, 30).Select

Selection.OnAction = "Draw4"

With Selection.Characters(Start:=1, Length:=23).Font

..Name = "Arial"

..FontStyle = "Regular"

..Size = 8

..ColorIndex = xlAutomatic

End With

With Selection

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

.ReadingOrder = xlContext

.Orientation = xlHorizontal

.AutoSize = True

.Placement = xlFreeFloating

.PrintObject = False

Selection.ShapeRange.IncrementLeft 402#

Selection.ShapeRange.IncrementTop -6.75

End With

Selection.Characters.Text = "Draw Number"

Application.Goto Reference:=Range("G1"), Scroll:=True
Range("P1").Select

Application.ScreenUpdating = True

End Sub

Sorry to be so long with this but thought the more details the better.

Thanks in advance
 
T

Tom Ogilvy

In a general module, put in this code:

Sub ABC()
Dim rng As Range
With Worksheets("Sheet2")
Set rng = .Range("A1", .Range("A1").End(xlDown))

rng.Offset(0, 1).Formula = "=rand()"
rng.Resize(, 2).Sort Key1:=.Range("B1"), _
Header:=xlNo
End With
With Worksheets("Sheet1")
.Range(rng.Address).Formula = "=if(row()<=Sheet2!$C$1," & _
"Offset(Sheet2!$A$1,row()-1,0),"""")"
End With
End Sub

now on Sheet1 put in a commandButton and use this code for the click event:

Private Sub CommandButton1_Click()
Dim rng As Range, rng1 As Range
Set rng = Worksheets("Sheet2").Range("C1")
Set rng1 = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp)
Debug.Print rng.Value, rng1.Row
If rng >= rng1.Row Or IsEmpty(rng) Then
rng.Value = 0
ABC
Else
rng = rng.Value + 1
End If

End Sub

Now if you click on the button, you should get your first word. Click until
you get all words. When you click again, it will resort the words and start
again.

--
regards,
Tom Ogilvy





Tim said:
We have a game like bingo but it uses words and not numbers, thought it
would be great if we could pick the words using excel. I have seen a sheet
that was used to draw numbers for Bingo, see code below, so my question is
can excel pick a random word or phrase without duplicates, and list them on
a sheet and then pick another one?


Here are the details.

The words or phrase are in sheet2 A1:A??? right now it is A50 but could be
more or less, It would need to pick a word from the list when a button is
clicked and put that word in lets say sheet1 A1, the next time it is clicked
it would need to pick a different word from the list and put it in sheet1 A2
an so on....

We would need someway to set the range in VBA if more words are added or
subtracted, ideally it would somehow "know" how many words were in sheet2
column A and adjust to that, don't even know if that is possible.

I have excel 2002

The code below may give you a better understanding of what I want to do.

If you run set_up_sheet it will set the sheet up like it needs to be then
just click on the draw button it see how it works, there is also a macro to
clear the sheet., clear_numbers.

I want it to work like this but to draw words from sheet2 A1 down



Option Explicit

Public Lottery As Variant

Public LotteryIndex As Long

Dim irow As Integer

Dim jcol As Integer

'Based on code by Tom Ogilvy 2002

'[slighty adapted by Max 2005)

Sub Clear_Numbers()

Dim msg, title, response As String

'clears the old numbers in draw mumbers sheet

msg = "Are You Sure You Want To Reset The Numbers ?"

title = "Continue ?"

response = MsgBox(msg, vbYesNo + vbQuestion, title)

If response = vbNo Then

Exit Sub ' Quit the macro

End If

Application.ScreenUpdating = False

Lottery = Shuffle()

LotteryIndex = LBound(Lottery)

irow = 2

jcol = 7

Cells(irow, jcol).CurrentRegion.ClearContents

Range("P3").Value = ""

Range("Q4").Select

Application.ScreenUpdating = True

End Sub


Private Sub InitLottery()

Lottery = Shuffle()

LotteryIndex = LBound(Lottery)

irow = 2

jcol = 7

Cells(irow, jcol).CurrentRegion.ClearContents

Range("P3").Value = ""

Range("Q4").Select

End Sub


Private Sub Draw4()

Dim vArr

Dim iMyNumber As Integer

Dim i As Byte



'draws the numbers



If Not IsArray(Lottery) Then

InitLottery

End If

If LotteryIndex > UBound(Lottery) Then

InitLottery

Cells(irow, jcol).CurrentRegion.ClearContents

End If

Range("P3").Formula = "=RandBetween(1,75)"

For i = 1 To 5

Application.Calculate

Next i

Range("P3").Value = Lottery(LotteryIndex)

Cells(irow, jcol).Value = Range("P3").Value

LotteryIndex = LotteryIndex + 1

irow = irow + 1

If irow = 12 Then

irow = 2

jcol = jcol + 1

End If



End Sub



Function Shuffle()

'

' Algorithm from:

' The Art of Computer Programming: _

' SemiNumerical Algorithms Vol 2, 2nd Ed.

' Donald Knuth

' p. 139

'

'

Dim List() As Long

Dim t As Long

Dim i As Long

Dim j As Long

Dim k As Long

Dim lngTemp As Long

Dim lbnd, ubnd As String

t = 100

lbnd = 1

ubnd = 75

t = ubnd - lbnd + 1

ReDim List(1 To t)

For i = 1 To t

List(i) = i + lbnd - 1

Next

j = t

Randomize

For i = 1 To t

k = Rnd() * j + 1

lngTemp = List(j)

List(j) = List(k)

List(k) = lngTemp

j = j - 1

Next

Shuffle = List

End Function


Sub Set_Up_Sheet()

'used to set the sheet up for demonstrating

Application.ScreenUpdating = False

Columns("G:N").Select

Selection.ColumnWidth = 3

Range("P5:Q8").Select

With Selection

.HorizontalAlignment = xlGeneral

.VerticalAlignment = xlBottom

.WrapText = False

.Orientation = 0

.AddIndent = False

.IndentLevel = 0

.ShrinkToFit = False

.ReadingOrder = xlContext

.MergeCells = True

End With

Selection.UnMerge

With Selection

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlBottom

.WrapText = False

.Orientation = 0

.AddIndent = False

.IndentLevel = 0

.ShrinkToFit = False

.ReadingOrder = xlContext

.MergeCells = False

End With

Selection.Merge

ActiveCell.FormulaR1C1 = _

"=IF(R[-2]C<1,"""",LOOKUP(R[-2]C,{0;16;31;46;61}," & _

"{""B"";""I"";""N"";""G"";""O""}))&"" ""&R[-2]C"

Range("P9").Select
Click to expand...
 
T

Tim

Tom, Thanks, and if I won't to start drawing before the list is complete do
I just clear sheet2 C1?

And if the list number changes should I clear sheet2 column B and sheet1
column A also so the formulas will be put back in right the next time?

Thanks again

Tim

Tom Ogilvy said:
In a general module, put in this code:

Sub ABC()
Dim rng As Range
With Worksheets("Sheet2")
Set rng = .Range("A1", .Range("A1").End(xlDown))

rng.Offset(0, 1).Formula = "=rand()"
rng.Resize(, 2).Sort Key1:=.Range("B1"), _
Header:=xlNo
End With
With Worksheets("Sheet1")
.Range(rng.Address).Formula = "=if(row()<=Sheet2!$C$1," & _
"Offset(Sheet2!$A$1,row()-1,0),"""")"
End With
End Sub

now on Sheet1 put in a commandButton and use this code for the click event:

Private Sub CommandButton1_Click()
Dim rng As Range, rng1 As Range
Set rng = Worksheets("Sheet2").Range("C1")
Set rng1 = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp)
Debug.Print rng.Value, rng1.Row
If rng >= rng1.Row Or IsEmpty(rng) Then
rng.Value = 0
ABC
Else
rng = rng.Value + 1
End If

End Sub

Now if you click on the button, you should get your first word. Click until
you get all words. When you click again, it will resort the words and start
again.

--
regards,
Tom Ogilvy





Tim said:
We have a game like bingo but it uses words and not numbers, thought it
would be great if we could pick the words using excel. I have seen a sheet
that was used to draw numbers for Bingo, see code below, so my question is
can excel pick a random word or phrase without duplicates, and list them on
a sheet and then pick another one?


Here are the details.

The words or phrase are in sheet2 A1:A??? right now it is A50 but could be
more or less, It would need to pick a word from the list when a button is
clicked and put that word in lets say sheet1 A1, the next time it is clicked
it would need to pick a different word from the list and put it in sheet1 A2
an so on....

We would need someway to set the range in VBA if more words are added or
subtracted, ideally it would somehow "know" how many words were in sheet2
column A and adjust to that, don't even know if that is possible.

I have excel 2002

The code below may give you a better understanding of what I want to do.

If you run set_up_sheet it will set the sheet up like it needs to be then
just click on the draw button it see how it works, there is also a macro to
clear the sheet., clear_numbers.

I want it to work like this but to draw words from sheet2 A1 down



Option Explicit

Public Lottery As Variant

Public LotteryIndex As Long

Dim irow As Integer

Dim jcol As Integer

'Based on code by Tom Ogilvy 2002

'[slighty adapted by Max 2005)

Sub Clear_Numbers()

Dim msg, title, response As String

'clears the old numbers in draw mumbers sheet

msg = "Are You Sure You Want To Reset The Numbers ?"

title = "Continue ?"

response = MsgBox(msg, vbYesNo + vbQuestion, title)

If response = vbNo Then

Exit Sub ' Quit the macro

End If

Application.ScreenUpdating = False

Lottery = Shuffle()

LotteryIndex = LBound(Lottery)

irow = 2

jcol = 7

Cells(irow, jcol).CurrentRegion.ClearContents

Range("P3").Value = ""

Range("Q4").Select

Application.ScreenUpdating = True

End Sub


Private Sub InitLottery()

Lottery = Shuffle()

LotteryIndex = LBound(Lottery)

irow = 2

jcol = 7

Cells(irow, jcol).CurrentRegion.ClearContents

Range("P3").Value = ""

Range("Q4").Select

End Sub


Private Sub Draw4()

Dim vArr

Dim iMyNumber As Integer

Dim i As Byte



'draws the numbers



If Not IsArray(Lottery) Then

InitLottery

End If

If LotteryIndex > UBound(Lottery) Then

InitLottery

Cells(irow, jcol).CurrentRegion.ClearContents

End If

Range("P3").Formula = "=RandBetween(1,75)"

For i = 1 To 5

Application.Calculate

Next i

Range("P3").Value = Lottery(LotteryIndex)

Cells(irow, jcol).Value = Range("P3").Value

LotteryIndex = LotteryIndex + 1

irow = irow + 1

If irow = 12 Then

irow = 2

jcol = jcol + 1

End If



End Sub



Function Shuffle()

'

' Algorithm from:

' The Art of Computer Programming: _

' SemiNumerical Algorithms Vol 2, 2nd Ed.

' Donald Knuth

' p. 139

'

'

Dim List() As Long

Dim t As Long

Dim i As Long

Dim j As Long

Dim k As Long

Dim lngTemp As Long

Dim lbnd, ubnd As String

t = 100

lbnd = 1

ubnd = 75

t = ubnd - lbnd + 1

ReDim List(1 To t)

For i = 1 To t

List(i) = i + lbnd - 1

Next

j = t

Randomize

For i = 1 To t

k = Rnd() * j + 1

lngTemp = List(j)

List(j) = List(k)

List(k) = lngTemp

j = j - 1

Next

Shuffle = List

End Function


Sub Set_Up_Sheet()

'used to set the sheet up for demonstrating

Application.ScreenUpdating = False

Columns("G:N").Select

Selection.ColumnWidth = 3

Range("P5:Q8").Select

With Selection

.HorizontalAlignment = xlGeneral

.VerticalAlignment = xlBottom

.WrapText = False

.Orientation = 0

.AddIndent = False

.IndentLevel = 0

.ShrinkToFit = False

.ReadingOrder = xlContext

.MergeCells = True

End With

Selection.UnMerge

With Selection

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlBottom

.WrapText = False

.Orientation = 0

.AddIndent = False

.IndentLevel = 0

.ShrinkToFit = False

.ReadingOrder = xlContext

.MergeCells = False

End With

Selection.Merge

ActiveCell.FormulaR1C1 = _

"=IF(R[-2]C<1,"""",LOOKUP(R[-2]C,{0;16;31;46;61}," & _

"{""B"";""I"";""N"";""G"";""O""}))&"" ""&R[-2]C"

Range("P9").Select
Click to expand...
Click to expand...
 
T

Tom Ogilvy

Yes, just clear Sheet2!C1. If that is blank when you click the button, it
resizes the list and reenters the formulas.


Each time it initializes, it rebuilds the formulas, but if the previous list
was longer than the current list, those formulas beyond the current list
size would remain - but they should still appear blank. I don't see any
reason to clear them. In the same situation, I don't think residual
formulas in column B of Sheet2 should cause any problem.

--
Regards,
Tom Ogilvy





Tim said:
Tom, Thanks, and if I won't to start drawing before the list is complete
do
I just clear sheet2 C1?

And if the list number changes should I clear sheet2 column B and sheet1
column A also so the formulas will be put back in right the next time?

Thanks again

Tim

Tom Ogilvy said:
In a general module, put in this code:

Sub ABC()
Dim rng As Range
With Worksheets("Sheet2")
Set rng = .Range("A1", .Range("A1").End(xlDown))

rng.Offset(0, 1).Formula = "=rand()"
rng.Resize(, 2).Sort Key1:=.Range("B1"), _
Header:=xlNo
End With
With Worksheets("Sheet1")
.Range(rng.Address).Formula = "=if(row()<=Sheet2!$C$1," & _
"Offset(Sheet2!$A$1,row()-1,0),"""")"
End With
End Sub

now on Sheet1 put in a commandButton and use this code for the click event:

Private Sub CommandButton1_Click()
Dim rng As Range, rng1 As Range
Set rng = Worksheets("Sheet2").Range("C1")
Set rng1 = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp)
Debug.Print rng.Value, rng1.Row
If rng >= rng1.Row Or IsEmpty(rng) Then
rng.Value = 0
ABC
Else
rng = rng.Value + 1
End If

End Sub

Now if you click on the button, you should get your first word. Click until
you get all words. When you click again, it will resort the words and start
again.

--
regards,
Tom Ogilvy





Tim said:
We have a game like bingo but it uses words and not numbers, thought it
would be great if we could pick the words using excel. I have seen a sheet
that was used to draw numbers for Bingo, see code below, so my question is
can excel pick a random word or phrase without duplicates, and list
them on
a sheet and then pick another one?


Here are the details.

The words or phrase are in sheet2 A1:A??? right now it is A50 but
could be
more or less, It would need to pick a word from the list when a button is
clicked and put that word in lets say sheet1 A1, the next time it is clicked
it would need to pick a different word from the list and put it in sheet1 A2
an so on....

We would need someway to set the range in VBA if more words are added
or
subtracted, ideally it would somehow "know" how many words were in sheet2
column A and adjust to that, don't even know if that is possible.

I have excel 2002

The code below may give you a better understanding of what I want to do.

If you run set_up_sheet it will set the sheet up like it needs to be then
just click on the draw button it see how it works, there is also a
macro to
clear the sheet., clear_numbers.

I want it to work like this but to draw words from sheet2 A1 down



Option Explicit

Public Lottery As Variant

Public LotteryIndex As Long

Dim irow As Integer

Dim jcol As Integer

'Based on code by Tom Ogilvy 2002

'[slighty adapted by Max 2005)

Sub Clear_Numbers()

Dim msg, title, response As String

'clears the old numbers in draw mumbers sheet

msg = "Are You Sure You Want To Reset The Numbers ?"

title = "Continue ?"

response = MsgBox(msg, vbYesNo + vbQuestion, title)

If response = vbNo Then

Exit Sub ' Quit the macro

End If

Application.ScreenUpdating = False

Lottery = Shuffle()

LotteryIndex = LBound(Lottery)

irow = 2

jcol = 7

Cells(irow, jcol).CurrentRegion.ClearContents

Range("P3").Value = ""

Range("Q4").Select

Application.ScreenUpdating = True

End Sub


Private Sub InitLottery()

Lottery = Shuffle()

LotteryIndex = LBound(Lottery)

irow = 2

jcol = 7

Cells(irow, jcol).CurrentRegion.ClearContents

Range("P3").Value = ""

Range("Q4").Select

End Sub


Private Sub Draw4()

Dim vArr

Dim iMyNumber As Integer

Dim i As Byte



'draws the numbers



If Not IsArray(Lottery) Then

InitLottery

End If

If LotteryIndex > UBound(Lottery) Then

InitLottery

Cells(irow, jcol).CurrentRegion.ClearContents

End If

Range("P3").Formula = "=RandBetween(1,75)"

For i = 1 To 5

Application.Calculate

Next i

Range("P3").Value = Lottery(LotteryIndex)

Cells(irow, jcol).Value = Range("P3").Value

LotteryIndex = LotteryIndex + 1

irow = irow + 1

If irow = 12 Then

irow = 2

jcol = jcol + 1

End If



End Sub



Function Shuffle()

'

' Algorithm from:

' The Art of Computer Programming: _

' SemiNumerical Algorithms Vol 2, 2nd Ed.

' Donald Knuth

' p. 139

'

'

Dim List() As Long

Dim t As Long

Dim i As Long

Dim j As Long

Dim k As Long

Dim lngTemp As Long

Dim lbnd, ubnd As String

t = 100

lbnd = 1

ubnd = 75

t = ubnd - lbnd + 1

ReDim List(1 To t)

For i = 1 To t

List(i) = i + lbnd - 1

Next

j = t

Randomize

For i = 1 To t

k = Rnd() * j + 1

lngTemp = List(j)

List(j) = List(k)

List(k) = lngTemp

j = j - 1

Next

Shuffle = List

End Function


Sub Set_Up_Sheet()

'used to set the sheet up for demonstrating

Application.ScreenUpdating = False

Columns("G:N").Select

Selection.ColumnWidth = 3

Range("P5:Q8").Select

With Selection

.HorizontalAlignment = xlGeneral

.VerticalAlignment = xlBottom

.WrapText = False

.Orientation = 0

.AddIndent = False

.IndentLevel = 0

.ShrinkToFit = False

.ReadingOrder = xlContext

.MergeCells = True

End With

Selection.UnMerge

With Selection

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlBottom

.WrapText = False

.Orientation = 0

.AddIndent = False

.IndentLevel = 0

.ShrinkToFit = False

.ReadingOrder = xlContext

.MergeCells = False

End With

Selection.Merge

ActiveCell.FormulaR1C1 = _

"=IF(R[-2]C<1,"""",LOOKUP(R[-2]C,{0;16;31;46;61}," & _

"{""B"";""I"";""N"";""G"";""O""}))&"" ""&R[-2]C"

Range("P9").Select
Click to expand...
Click to expand...
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Remove Identical words 0
Macro to Select text from a point given to a specific word 2
Help needed! Extracting Heading 3 and Contents from a Word Doc to Excel 0
Word Macro for multiple searches, incl. in footnotes 2
If cancel list box don't enter FALSE in list 2
Search an array of sheets for an array of numbers & return count of numbers 11
MACRO Effeciency 3
Find string from column A in Range("B2:F7") list the header of that column/s 5

Top