Creating a Wheel Of Fortune with Excel
Content
- Introduction
- Generating the numbers
- Animating the numbers
- Controlling the highest possible number in the draw
- Making it look like a wheel
- VBA code
- The end result
- Other fun stuff from my website
Introduction
Excel is a very serious and powerful business application. That doesn't mean we can't have some fun with it. In this article I'll explain how I've built an Excel file which enables you to play with a wheel of fortune. With sound and all!
This is what it'll look like when we're done:
Download the accompanying file from here
Generating the numbers
Getting random numbers isn't hard in Excel, that is what the RAND() function is for. We'll use a two-column table. The first column contains whole numbers 1 ... 300. The second contains the =RAND() function. When we're about to do a draw, we simply sort the table on column B. This is what our table looks like (worksheet Step 1):
Worksheet Step 2 shows the prepared list of numbers, still in their 1, 2, 3 order. I've picked a rather arbitrary cell as the "drawn number cell", in this case cell A14. So after a recalc and sort, cell A14 already displays our winning number. The winner is 13. Column D will hold our previous winners.
Boring of course. We want animation!
Animating the numbers
On worksheet Step 3 we'll start using the table on sheet Step 2. I've left the table in 1, 2, 3 sort for now so we can easily see how it works.
Cell C3 contains a fixed number. We'll start incrementing that number when we start a draw. Cells C4:C28 contain a simple formula: =C3+1. So as soon as we add 1 to cell C3, 1 will be added to all cells below that too.
We'll use these numbers to pick the numbers from the previous worksheet, using the OFFSET function. See Cell G3: =OFFSET('Step 2'!$A$1,C3,0,1,1)
Try entering 1, 2, 3, 4 into cell C3 and see what happens. If you're quick enough, the numbers will appear to be moving.
Controlling the highest possible number in the draw
I needed a way to set a maximum number (the wheel of fortune was used at an event and we didn't know up front how many participants there would be). Worksheet Step 4 demonstrates how this was done.
In cell B1 the max number is set. This cell is used by some formulas AND by a little VBA macro we'll get to later.
Lets have a look at column D. It contains this formula: =MOD(C3,$B$1)+1. In effect, this formula causes the numbers to "roll over": to restart at 1, as soon as a cell in col C reaches the maximum value. And I've modified the formula in column F to now use column D for the index, rather than column C. Try entering a number into cell C3 which is close to the current max in cell B1 and you'll see what I mean:
Making it look like a wheel
So now that we've got the numbers right, lets do some formatting.
Click on sheet "Wheel 1". You'll see I've removed all helper columns, leaving just our list of numbers for the wheel and the pointer to the winning cell:
On Sheet Wheel 2 I have added some colors and borders. This is starting to look nice!
Lets turn to Sheet Wheel 3. I've added quite some trickery there!
- Conditional formatting (look at column AA for the formulas) ensures the number cells have alternate colors
- Two extra columns (to the left and right of the wheel) have been added. Their shading of every fifth row will trick our eyes into believing the wheel turns!
- I've also fiddled around with the font sizes, making the cells near the top and bottom of the wheel appear further away. Just like in a real wheel.
Sheet Wheel 4 shows the one-but-last stage, where I have modified row heights and column widths. Pretty?
Lets turn to sheet Play.
Notice the flashy letters? Conditional formatting again!
Alas, the wheel doesn't turn without some VBA code.
VBA code
I'm going to be a bit lazy and just dump the code here. There are two modules.
Module modPlay
The trickery here is that this routine called "SpinIt" auto-adjusts itself so that it'll take precisely 18 seconds to finish turning the wheel. Why? Because I've added sound effects and the sound effect file (WheelOfFortune.wav) takes 18 seconds to play!
Dim mlLoopFactor As Long
Sub SpinIt()
Dim lCT As Long
Dim lCt2 As Long
Dim lCount As Long
Dim dTime As Double
Dim dStart As Double
Dim bOK As Boolean
If mlLoopFactor = 0 Then mlLoopFactor = 5000
lCount = Worksheets("Step 4").Range("B1").Value
Application.ScreenUpdating = False
With Worksheets("Step 2")
Do
Application.Calculate
.Range("A1:B300").Sort Key1:=.Range("A1"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
.Range("A1:B" & lCount + 1).Sort Key1:=.Range("B1"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
bOK = Add2Numbers(.Range("A14").Value)
Loop Until bOK
End With
Application.ScreenUpdating = True
PlayBackLoop
dStart = Timer
With Worksheets("Step 4")
For lCT = lCount To 0 Step -1
.Range("C3").Value = lCT
' DoEvents
dTime = Timer
Do
Loop Until Timer - dTime > (lCount - lCT) / mlLoopFactor
Next
End With
dStart = (Timer - dStart)
'17.5/time*(1/loopcounter)
mlLoopFactor = 1 / (17.5 / dStart * (1 / mlLoopFactor))
PlayBackStop
Application.Wait Now + TimeValue("00:00:01")
Range("Result").Speak
End Sub
Function Add2Numbers(lValue As Long) As Boolean
Dim ocell As Range
Dim oSh As Worksheet
Set oSh = Worksheets("Step 2")
Set ocell = oSh.Range("D2:D1000").Find(lValue, oSh.Range("D2"), xlValues, xlWhole, , xlNext, False, , False)
If ocell Is Nothing Then
Add2Numbers = True
oSh.Range("D" & oSh.Rows.Count).End(xlUp).Offset(1).Value = lValue
Else
Add2Numbers = False
End If
End Function
Public Sub ResetNumbers(Optional bAsk As Boolean = True)
Dim oSh As Worksheet
Dim bDo As Boolean
Set oSh = Worksheets("Step 2")
If bAsk Then
bDo = (MsgBox("Are you sure you want to start over?", vbQuestion + vbYesNo) = vbYes)
Else
bDo = True
End If
If bDo Then
oSh.Range(oSh.Range("D2"), oSh.Range("D" & oSh.Rows.Count).End(xlUp).Offset(1)).Clear
End If
End Sub
Module modSound
To play the sound I used some Windows API stuff. Don't worry if you don't understand this, set it and forget it!
#If VBA7 Then
Private Declare PtrSafe Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _
(ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
#Else
Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _
(ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
#End If
'Sound constants
Private Const SND_SYNC = &H0
Private Const SND_ASYNC = &H1
Private Const SND_NODEFAULT = &H2
Private Const SND_LOOP = &H8
Private Const SND_NOSTOP = &H10
Sub PlayBackLoop()
If Len(Dir(ThisWorkbook.Path & "\WheelOfFortune.wav")) > 0 Then
WAVLoop ThisWorkbook.Path & "\WheelOfFortune.wav"
End If
End Sub
Sub PlayBackStop()
Call WAVPlay(vbNullString)
End Sub
Sub WAVLoop(File As String)
Dim SoundName As String
Dim wFlags As Long
Dim x As Long
SoundName = File
wFlags = SND_ASYNC Or SND_LOOP
x = sndPlaySound(SoundName, wFlags)
If x = 0 Then MsgBox "Can't play the audio file. ", vbCritical, "Error"
End Sub
Sub WAVPlay(File As String)
Dim SoundName As String
Dim wFlags As Long
Dim x As Long
SoundName = File
wFlags = SND_ASYNC Or SND_NODEFAULT
x = sndPlaySound(SoundName, wFlags)
If x = 0 Then MsgBox "Can't play the audio file. ", vbCritical, "Error"
End Sub
The end result
Before I forget, this is the end result. The animated gif isn't as nice as the Excel file however, so make sure you download it (link at top).
Other fun stuff from my website
That's all folks!
Comments
All comments about this page:
Comment by: Anna (5-10-2016 10:42:46) deeplink to this comment
I love the wheel of fortune but the sound of the wheel turning doesn't play. Can you tell me how to make it?
Thanks.
Comment by: Jan Karel Pieterse (5-10-2016 11:11:51) deeplink to this comment
Hi Anna,
To get the sound you must make sure you copy both files inside the zip file to the same directory and then open the Excel file from that folder.
Comment by: michael rodriguez (6-12-2016 18:20:50) deeplink to this comment
I would like to know how to create this and instead of drawing numbers draw names from it if possible thank you very much
Comment by: Jan Karel Pieterse (6-12-2016 20:55:16) deeplink to this comment
Hi michael,
Doesn't the article explain it clear enough?
You can simply replace the numbers in the first column on worksheet Step 2. Also, change a little bit of the VBA code. This:
needs to be replaced with:
Comment by: michael rodriguez (13-12-2016 17:49:04) deeplink to this comment
Hi again I currently created a table with names and the wheel spins but I only have 20 people on the list and the wheel gets jammed up as the macro runs, how can I fix this to run wheel of name smooth? thanks in advance
Comment by: Jan Karel Pieterse (13-12-2016 18:41:22) deeplink to this comment
Hi Micheal,
Perhaps you can simply repeat the list of names 5 times to get a hundred of them?
Comment by: Chuck fox (14-3-2017 23:58:51) deeplink to this comment
I'am sure this is not the right place to ask this but it does have to do with rolling numbers. Any advise would be helpful.
Thank You
Chuck fox
Tried to make a rolling number counter so that you can watch the numbers roll up to a set number ( 1-500 ) in a set time (2 sec.) ( cell a1= start number) ( A2= End number ) ( A3 = run time) (A4 = shows numbers rolling up to end number) I use excel 2016
I used this (=IF(H6=1,H7+1*H5,0) ) in excel 2007 and set the Enable Interative Calculation To/On I set the max interations TO 15000 & max change To .001 it was great.
But the same setting in excel 2016 just pop's the number up in the cell. What am I missing about excel 2016?
Comment by: Rupert Mergan (26-1-2019 18:36:01) deeplink to this comment
Hi Jan Karel,
Great tool. One remark: when I use a longer list (about 850 entries) to draw from, the macro runs without stopping. I fixed this by increasing the mLoopFactor to 50000 instead of 5000.
Br,
Rupert
Comment by: Rich (29-1-2019 16:11:56) deeplink to this comment
This is AWESOME!!!!!!!!!!!!
Quick question though...
I was trying to adjust the conditional formatting for cell fill color in "I30" as well as "H29:H31" and "J29:J31"
Formatting formula looks right, do you know the fix?
By the way......AWESOME!!!!!!!!!!
Comment by: Richard Cicconetti (30-1-2019 07:50:49) deeplink to this comment
Hi Jan,
I emailed earlier and I have a more technical question about your Wheel of Fortune.
I have infused it into a workbook I had been writing as a marketing tool. I've been at it all day!! I'm not quite sure what I did, but I can't get the wheel to spin for very long. Otherwise, everything works great!
I was hoping you would be kind enough to proofread the vba.
I can tell you this: I had to remove the option explicit (Dim msLoopFactor as Long) declaration from the top of the vba. I placed it at the head of the Sub 'SpinIt'. It was not allowing for many of the other arguments I have running in the code. (Specifically, If Then statements that return MsgBox.)
If you're interested in seeing my version of your work and wouldn't mind sparing a few minutes, I would greatly appreciate it!
Thanks in advance for your consideration..
Rich C
Comment by: Jan Karel Pieterse (2-2-2019 16:12:29) deeplink to this comment
Hi Richard,
Sure, you can email it to me if you like.
Comment by: SAPPHIRE VALDEZ POLINAR (15-11-2019 16:05:00) deeplink to this comment
how to change it to names? with speeh?
Comment by: Jan Karel Pieterse (15-11-2019 16:11:00) deeplink to this comment
Hi
Very simple, just enter your list of names into the cells in column A of the second worksheet and then change this bit in the VBA code:
to this
Comment by: Gian (18-2-2020 17:02:00) deeplink to this comment
Hi, I found your file really nice! but i am having an issue when i need to only select 10 players or less i encounter an issue, this file is set for 300 guests/numbers, could you please advice how can i modify the BVA code in order to have the wheel work no matter the amount of players/numbers are in the list and excluding the Zeros.
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
.Range("A1:B" & lCount + 1).Sort Key1:=.Range("B1"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Comment by: Jan Karel Pieterse (18-2-2020 18:00:00) deeplink to this comment
Hi Gian,
I'm afraid the wheel of fortune needs at least as many numbers as I put on the visible part of the wheel (26).
Comment by: Gian (18-2-2020 19:39:00) deeplink to this comment
Thanks for your answer Jan, Well, I'll try something on my own but i doubt i can fix the issue ):, any way it is a great file for any one who uses it, Thank you for showing us how to do it as well!
Comment by: Lloyd (28-7-2020 11:24:00) deeplink to this comment
Hi, i am trying to use your wheel of fortune code for my company's lucky draw. I tried to do it using your example however, VBA keep prompting me an error saying "Sub or function not defined. Is it possible if I email you the file and help me to take a look at it?
Comment by: Jan Karel Pieterse (28-7-2020 11:51:00) deeplink to this comment
Hi Lloyd,
Sure, go ahead and send the file. Please refer to this message too.
Comment by: Jeremy (5-10-2022 00:10:00) deeplink to this comment
Firstly, thank you so much for sharing your knowledge.
Whenever I edit, particularly when changing the number of rows, the VBA breaks here...
bOK = Add2Numbers(.Range("A14").Value)
Thank you for any suggestions you have!
Comment by: Jan Karel Pieterse (5-10-2022 10:16:00) deeplink to this comment
Hi Jeremy,
Precisely which error do you get please?
Comment by: Brandon (10-11-2023 04:22:00) deeplink to this comment
How would you ensure that the already drawn numbers are not selected again upon respin?
Comment by: Jan Karel Pieterse (10-11-2023 11:10:00) deeplink to this comment
Hi Brandon,
In the VBA code there is a function called Add2Numbers which tries to add the current random number to a list of previously selected numbers. It returns True if the new number is not in the list and false if it already is. The calling routine has a Do loop which continues to run until that function returns True.
Have a question, comment or suggestion? Then please use this form.
If your question is not directly related to this web page, but rather a more general "How do I do this" Excel question, then I advise you to ask your question here: www.eileenslounge.com.