Dice rolling monitor - can someone tidy this code up?

C

chuckles1066

Banned
Joined
Dec 20, 2004
Messages
372
This works but I'm sure it's unnecessarily bloated.

Also, it terminates with a "Return without GoSub" error which isn't important because the 65535 passes have completed but it's annoying.

Code: 
Sub RollDice()
    
Dim Dice1, Dice2 As Integer
Dim rollcount As Long

Randomize
Application.ScreenUpdating = False

For rollcount = 1 To 65535

Dice1 = Int(Rnd() * 6) + 1
Dice2 = Int(Rnd() * 6) + 1

Select Case Dice1
    Case 1
        GoSub d11
    Case 2
        GoSub d12
    Case 3
        GoSub d13
    Case 4
        GoSub d14
    Case 5
        GoSub d15
    Case 6
        GoSub d16
End Select
Next

d11:
Select Case Dice2
    Case 1
        Cells(1, 2).Value = Cells(1, 2).Value + 1
    Case 2
        Cells(2, 2).Value = Cells(2, 2).Value + 1
    Case 3
        Cells(3, 2).Value = Cells(3, 2).Value + 1
    Case 4
        Cells(4, 2).Value = Cells(4, 2).Value + 1
    Case 5
        Cells(5, 2).Value = Cells(5, 2).Value + 1
    Case 6
        Cells(6, 2).Value = Cells(6, 2).Value + 1
End Select
Return

d12:
Select Case Dice2
    Case 1
        Cells(2, 2).Value = Cells(2, 2).Value + 1
    Case 2
        Cells(7, 2).Value = Cells(7, 2).Value + 1
    Case 3
        Cells(8, 2).Value = Cells(8, 2).Value + 1
    Case 4
        Cells(9, 2).Value = Cells(9, 2).Value + 1
    Case 5
        Cells(10, 2).Value = Cells(10, 2).Value + 1
    Case 6
        Cells(11, 2).Value = Cells(11, 2).Value + 1
End Select
Return

d13:
Select Case Dice2
    Case 1
        Cells(3, 2).Value = Cells(3, 2).Value + 1
    Case 2
        Cells(8, 2).Value = Cells(8, 2).Value + 1
    Case 3
        Cells(12, 2).Value = Cells(12, 2).Value + 1
    Case 4
        Cells(13, 2).Value = Cells(13, 2).Value + 1
    Case 5
        Cells(14, 2).Value = Cells(14, 2).Value + 1
    Case 6
        Cells(15, 2).Value = Cells(15, 2).Value + 1
End Select
Return

d14:
Select Case Dice2
    Case 1
        Cells(4, 2).Value = Cells(4, 2).Value + 1
    Case 2
        Cells(9, 2).Value = Cells(9, 2).Value + 1
    Case 3
        Cells(13, 2).Value = Cells(13, 2).Value + 1
    Case 4
        Cells(16, 2).Value = Cells(16, 2).Value + 1
    Case 5
        Cells(17, 2).Value = Cells(17, 2).Value + 1
    Case 6
        Cells(18, 2).Value = Cells(18, 2).Value + 1
End Select
Return

d15:
Select Case Dice2
    Case 1
        Cells(5, 2).Value = Cells(5, 2).Value + 1
    Case 2
        Cells(10, 2).Value = Cells(10, 2).Value + 1
    Case 3
        Cells(14, 2).Value = Cells(14, 2).Value + 1
    Case 4
        Cells(17, 2).Value = Cells(17, 2).Value + 1
    Case 5
        Cells(19, 2).Value = Cells(19, 2).Value + 1
    Case 6
        Cells(20, 2).Value = Cells(20, 2).Value + 1
End Select
Return

d16:
Select Case Dice2
    Case 1
        Cells(6, 2).Value = Cells(6, 2).Value + 1
    Case 2
        Cells(11, 2).Value = Cells(11, 2).Value + 1
    Case 3
        Cells(15, 2).Value = Cells(15, 2).Value + 1
    Case 4
        Cells(18, 2).Value = Cells(18, 2).Value + 1
    Case 5
        Cells(20, 2).Value = Cells(20, 2).Value + 1
    Case 6
        Cells(21, 2).Value = Cells(21, 2).Value + 1
End Select
Return
End Sub
 

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
Sort by date Sort by votes
it terminates with a "Return without GoSub"
Click to expand...
There should be an Exit Sub after the Next line.

What does the code do?
 
Upvote 0
shg said:
There should be an Exit Sub after the Next line.

What does the code do?
Click to expand...

All possible dice rolls are stored in column A, starting with 1,1 then 1,2 right down to 6,6.

Obviously, 2,1 is the same as 1,2 for example so isn't included.

Column B stores each occurence of each roll.
 
Upvote 0
How about a slight rearrangment?

Code: 
Sub RollDice()
    Dim Die1      As Long
    Dim Die2      As Long
    Dim iRoll     As Long
 
    With Range("A1")
        .Offset(, 1).Resize(, 6).Value = Array(1, 2, 3, 4, 5, 6)
        .Offset(1).Resize(6).Value = Application.Transpose(Array(1, 2, 3, 4, 5, 6))
        .Offset(1, 1).Resize(6, 6).ClearContents
 
        Randomize
        Application.ScreenUpdating = False
 
        For iRoll = 1 To 65535
            Die1 = Int(Rnd() * 6) + 1
            Die2 = Int(Rnd() * 6) + 1
            With .Offset(Die1, Die2)
                .Value = .Value + 1
            End With
        Next iRoll
    End With
End Sub
 
Upvote 0
Actually, I think you want a triangular matrix:
Code: 
Sub RollDice()
    Dim Die1      As Long
    Dim Die2      As Long
    Dim iRoll     As Long
 
    With Range("A1")
        .Offset(, 1).Resize(, 6).Value = Array(1, 2, 3, 4, 5, 6)
        .Offset(1).Resize(6).Value = Application.Transpose(Array(1, 2, 3, 4, 5, 6))
        .Offset(1, 1).Resize(6, 6).ClearContents
 
        Randomize
        Application.ScreenUpdating = False
 
        For iRoll = 1 To 65535
            Die1 = Int(Rnd() * 6) + 1
            Die2 = Int(Rnd() * 6) + 1
 
            If Die1 > Die2 Then
                With .Offset(Die1, Die2)
                    .Value = .Value + 1
                End With
            Else
                With .Offset(Die2, Die1)
                    .Value = .Value + 1
                End With
            End If
        Next iRoll
    End With
End Sub
 
Upvote 0
You could avoid the whole GoSub structure with this
Code: 
Sub RollDice()
    Dim Dice1, Dice2 As Integer
    Dim rollcount As Long
    Dim cellAffected As Range

    Randomize
    Application.ScreenUpdating = False

    For rollcount = 1 To 65536
    
        Dice1 = Int(Rnd() * 6) + 1
        Dice2 = Int(Rnd() * 6) + 1
        
        Select Case (10 * Dice1) + Dice2
            Case 11
                Set cellAffected = Cells(1, 2)
            Case 12
                Set cellAffected = Cells(2, 2)
            Case 13
                Set cellAffected = Cells(3, 2)
            Case 14
                Set cellAffected = Cells(4, 2)
            Case 15
                Set cellAffected = Cells(5, 2)
            Case 16
                Set cellAffected = Cells(6, 2)
                
            Case 21
                Set cellAffected = Cells(2, 2)
            Case 22
                Set cellAffected = Cells(7, 2)
            Case 23
                Set cellAffected = Cells(8, 2)
            Case 24
                Set cellAffected = Cells(9, 2)
            Case 25
                Set cellAffected = Cells(10, 2)
            Case 26
                Set cellAffected = Cells(11, 2)
                
            Case 31
                Set cellAffected = Cells(3, 2)
            Case 32
                Set cellAffected = Cells(8, 2)
            Case 33
                Set cellAffected = Cells(12, 2)
            Case 34
                Set cellAffected = Cells(13, 2)
            Case 35
                Set cellAffected = Cells(14, 2)
            Case 36
                Set cellAffected = Cells(15, 2)
                
            Case 41
                Set cellAffected = Cells(4, 2)
            Case 42
                Set cellAffected = Cells(9, 2)
            Case 43
                Set cellAffected = Cells(13, 2)
            Case 44
                Set cellAffected = Cells(16, 2)
            Case 45
                Set cellAffected = Cells(17, 2)
            Case 46
                Set cellAffected = Cells(18, 2)
                
            Case 51
                Set cellAffected = Cells(5, 2)
            Case 52
                Set cellAffected = Cells(10, 2)
            Case 53
                Set cellAffected = Cells(14, 2)
            Case 54
                Set cellAffected = Cells(17, 2)
            Case 55
                Set cellAffected = Cells(19, 2)
            Case 56
                Set cellAffected = Cells(20, 2)
                
            Case 61
                Set cellAffected = Cells(6, 2)
            Case 62
                Set cellAffected = Cells(11, 2)
            Case 63
                Set cellAffected = Cells(15, 2)
            Case 64
                Set cellAffected = Cells(18, 2)
            Case 65
                Set cellAffected = Cells(20, 2)
            Case 66
                Set cellAffected = Cells(21, 2)
        End Select
        
        cellAffected = cellAffected.Value + 1
    Next rollcount
End Sub
 
Upvote 0
Here's a tweak of shg's code that is much faster:
Code: 
Sub RollDice()
    Dim Die1      As Long
    Dim Die2      As Long
    Dim iRoll     As Long
    Dim numRolls As Long, Arr(1 To 6, 1 To 6)
    
    numRolls = Range("A1").Value
 
    With Range("A1")
        .Offset(, 1).Resize(, 6).Value = Array(1, 2, 3, 4, 5, 6)
        .Offset(1).Resize(6).Value = Application.Transpose(Array(1, 2, 3, 4, 5, 6))
        .Offset(1, 1).Resize(6, 6).ClearContents
 
        Randomize
        Application.ScreenUpdating = False
        
        For iRoll = 1 To numRolls
            Die1 = Int(Rnd() * 6) + 1
            Die2 = Int(Rnd() * 6) + 1
            Arr(Die1, Die2) = Arr(Die1, Die2) + 1
        Next iRoll
        .Offset(1, 1).Resize(6, 6) = Arr
    End With
    
End Sub
Enter the number of rolls you want in cell A1.
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Solved
Macro To Move Files - Will Not Move .msg or .csv files
Replies
4
Views
104
rachel06
R
I
  • Solved
Listbox on userform to show results in reverse order
2
Replies
16
Views
261
Fuji
F
A
  • Solved
VBA Case Error
Replies
2
Views
64
Ark68
A
R
  • Solved
Export excel file as PDF into a targeted pc folder based on cell value
Replies
2
Views
269
Ramadan2512
R
M
  • Solved
Navigate Userforms
Replies
6
Views
272
My Aswer Is This
My Aswer Is This

Forum statistics

Threads
1,224,521
Messages
6,179,286
Members
452,902
Latest member
Knuddeluff

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top