Dice Rolling Template

[billyshears]

Does anyone have a template I can download to simulate dice rolling complete with something that looks like Dice? I need something quick and dont have time to build it

 

[Logit]

Option Explicit

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub DiceRoll()
  Dim i As Long
 
  For i = 1 To 20
    Sleep i ^ 2
    Range("A1") = Int(6 * Rnd() + 1)
    Range("B1") = Int(6 * Rnd() + 1)
    Range("C1") = Int(6 * Rnd() + 1)
    DoEvents
  Next i
End Sub

Doesn't have actual "rolling" dice but the numbers change from fast to slow and then stop.

Download : Roll The Dice Slow Down.xlsm

 

[lrobbo314]

Here is my solution. It has a little bit of a 'rolling' animation.

The formatting looks weird here on the forum, but if you set up the 'dice' cells as

• Centered
• Left Justified
• Wrap Text
• Width: 92px
• Height: 103px

Dice.xlsm
	A	B	C	D	E	F
1	●	● ●	● ● ●	● ● ● ●	● ● ● ● ●	● ● ● ● ● ●
2
3
4
5
6
7
8
9	● ● ● ● ●	● ● ● ● ● ●
10
11
12
13	Total:	11
Sheet1

Cell Formulas
Range	Formula
B13	B13	=MATCH(B9,A1:F1,0)+MATCH(A9,A1:F1,0)

Sub ROLL()
Dim AR() As Variant: AR = Range("A1:F1").Value
Dim AL As Object: Set AL = CreateObject("System.Collections.ArrayList")
Dim D1 As Integer, D2 As Integer, x As Integer

For i = 1 To 500
    SETAL AR, AL
    setD AL, D1
    setD AL, D2
    Range("A9").Value = AR(1, D1)
    Range("B9").Value = AR(1, D2)
Next i
End Sub

Sub SETAL(AR() As Variant, AL As Object)
For i = 1 To UBound(AR, 2)
    AL.Add i
Next i
End Sub

Sub setD(AL As Object, D As Integer)
Dim x As Integer

x = Int((AL.Count - 1) * Rnd() + 1)
D = AL(x)
AL.Remove x
End Sub

 

[Kaper]

Well, this site is not "excel related", and the dice is 10-sided, while here was a discussion on traditional 6-sided dice.

If one uses Excel2016 or more recent version, UNICHAR function could be used to present standard dice faces.

Adopted @Logit code could be:

Option Explicit

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub DiceRoll()
  Dim i As Long, j As Long
 
  For i = 1 To 20
    Sleep i ^ 2
    For j = 1 To 3
      Cells(1, j).Value = Evaluate("=UNICHAR(" & Int(6 * Rnd() + 9856) & ")")
    Next j
    DoEvents
  Next i
End Sub

It looks better if one uses rather large font size (dice faces are smaller than standard letters) and horizontal+vertical centering of the cell contents:

 

[Kaper]

PS. I thought it would be nice to add some sound while dices are rolling, so:

Option Explicit

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare PtrSafe Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _
(ByVal lpszSoundName As String, ByVal uFlags As Long) As Long

Sub DiceRoll()
  Dim i As Long, j As Long
  Range("A1:C1").ClearContents
  For j = 1 To 3
    i = sndPlaySound("C:\Users\Kaper\test\roll.wav", CLng(&H3))
    Sleep 250 'adjust numbers to fit the sound
    For i = 9 To 15 'adjust numbers to fit the sound
      Cells(1, j).Value = Evaluate("=UNICHAR(" & Int(6 * Rnd() + 9856) & ")")
      Sleep i ^ 2
    Next i
    DoEvents
  Next j
End Sub

The wav file was downloaded from: http://www.gnubg.org/win32/wavs/roll.wav
Of course folder has to be adjusted in the code (unless you have Users\Kaper\test on your computer )