Creating a Wheel Of Fortune with Excel
Content
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!
Option Explicit
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!
Option Explicit
#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
Lotto (Bingo)
Tombola
That's all folks!
