Draw random words from a list without duplicates, VBA

[AC]

We have a game like bingo that we use at church 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, 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, unlike BINGO there are not some words that have to fall under B I N G O, the words can be anywhere on the cards so it would only 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

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

Thanks in advance

 

[jindon]

AC,
Add a command button (CommandButton1) on Sheet1 and
paste the code onto Sheet1 module and select other sheet once
then come back to Sheet1 and click the button

Priavate a() As Variant, dic As Object

Priavet Sub Worksheet_Activate()
   Dim e As Variant, r As Range
   Set dic = CreateObject("Scripting.Dictionary")
   dic.CompareMode = vbTextCompare
   With Sheets("Sheet2")
      a = .Range("a1",.Range("a" & Rows.Count).End(xlUp)).Value
   End With
   For Each e In a
      If Not dic.exists(e) Then dic.add e, Nothing
   Next
   For Each r In Range("a1",Range("a" & Rows.Count).End(xlUp))
      If dic.exists(r.Value) Then dic.remove(r.Value)
   Next
End Sub

Private Sub CommandButton1_Click()
   Dim i As Long
   ReDim Preserve a(1 To UBound(a,1), 1 To 2)
   Randomize
   For i = 1 To UBound(a,1)
      a(i,2) = Rnd
   Next
   VSortMA a, 1, UBound(a,1), 2
   i = 1
   Do While i <= UBound(a,1)
      If dic.exists(a(i,1)) Then Exit Do
      i = i + 1
   Loop
   Range("a" & Rows.Count).End(xlUp).Offset(1) = a(i,1)
   dic.remove(a(i,1))
End Sub

Private Sub VSortMA(ary, LB, UB, ref)
   Dim M As Variant, temp
   Dim i As Long, ii As Long, iii As Long
   i = UB : ii = LB
   M = ary(Int((LB + UB) / 2), ref)
   Do While ii <= i
      Do While ary(ii, ref) < M
         ii = ii + 1
      Loop
      Do While ary(i, ref) > M
         i = i - 1
      Loop
      If ii <= i Then
         For iii = LBound(ary, 2) To UBound(ary, 2)
            temp = ary(ii,iii) : ary(ii,iii) = ary(i,iii) : ary(i,iii) = temp
         Next
         ii = ii + 1 : i = i - 1
      End If
   Loop
   If LB < i Then VSortMA ary, LB, i, ref
   If ii < UB Then VSortMA ary, ii, UB, ref
End Sub

 

[AC]

Jindon,

Is all this code to be put in the sheet1 module?

When I click on the command button I get a runtime error type mismatch, when I debug this line is highlighted.
ReDim Preserve a(1 To UBound(a, 1), 1 To 2)

Thanks

 

[jindon]

AC

Can you just change

Private a As Variant, dic As Object

to

Private a() As Varinat, dic As Variant

 

[AC]

now when I click on sheet1 I get runtime error 429, activex component can't create object and this line highlighted

Set dic = CreateObject("Scripting.Dictionary")

 

[jindon]

now when I click on sheet1 I get runtime error 429, activex component can't create object and this line highlighted

Set dic = CreateObject("Scripting.Dictionary")

AC

Are you on LAN enviroment?
If so, you need to contact Net Work Admin to get access to DAO.

 

[AC]

Jindon, no I am not on a lan, this computer is not hooked to a network

 

[PA HS Teacher]

Here's a related thread you might want to have a look at.

http://www.mrexcel.com/board2/viewtopic.php?t=239378&highlight=

 

[AC]

PA HS Teacher,

Thanks, I can make the cards, but I like the way this does it with a macro, had to change the 31 in the line mySelect = Int((31 * Rnd) + 6) to get it to pick from rows below 37.

What I want to do is to have it draw the words like you were drawing numbers in a bingo game. 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()

'Application.Goto Reference:=Range("G1"), Scroll:=True
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
Add_Button
End Sub
Private Sub Add_Button()
'Place button from the forms toolbar
'Add Codes: Left start position, Top start position,
'Button width & Button hight in points!
'Note: Button position cannot be directly assigned to a cell address!
' If the column sizes are different then the button may be placed wrong!
ActiveSheet.Buttons.Add(90, 32, 150, 30).Select

'Attach this macro to the button!
Selection.OnAction = "Draw4"

'Format button caption text!
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
        
        'set the button so it will not move or print
        .Placement = xlFreeFloating
        .PrintObject = False
           
    'puts the button where I want it
    Selection.ShapeRange.IncrementLeft 402#
    Selection.ShapeRange.IncrementTop -6.75
    
      
    End With

'Button caption text!
Selection.Characters.Text = "Draw Number"
Application.Goto Reference:=Range("G1"), Scroll:=True

Range("P1").Select
End Sub

 

[AC]

Got some code from Tom Ogilvy to do it

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