こんにちは！サイコロが好きすぎるtknriaです！
サイコロって美しい！特に、表裏面を足したら7になるあたりとか！
小さい頃からなぜかサイコロが好きで、一人遊びの時期にもよくサイコロを使っていました。
そのときに考案したゲームの一つに「サイコロ野球」というものがあり、ふとこれを思い出しました。
■ サイコロ野球とは！
遊び方は単純で、いくつかのルールに従ってサイコロを振りまくるだけ。
１．サイコロを1つ振る。・・・Ａとする
２．Ａが「1」「2」なら５．に進み、それ以外なら３．に進む。
３．もう1度サイコロを1つ降る。・・・Ｂとする
４． Ａ－Ｂ－１≧１なら、その回の得点にＡ－Ｂ－１を足す。
５．もう1度サイコロを1つ降り、「1」「6」なら１．に戻る、それ以外なら攻守交代。
この作業を1回表から順に繰り返します。
この１．～４．の一連の作業で得られる最大得点はＡ＝６、Ｂ＝１のときの４点で、これが満塁ホームランにあたるので、すなわちＢ＝１ならホームラン。
５．で「1」「6」が出続ければ、どこまでも1イニングの得点を増やせます。
小学生ながら、よく考えられていたと思っています。
これをいつまでもサイコロでやっていたら成長がないので、Excel VBAで実装します。
■ Excel VBAでサイコロ野球！
写真のようにsheetを設定し、command buttonを一つ用意します。
ここで大事なのは、
・A1～A3は初期設定で1,1,0としておくこと
・F2～Q3は初期設定で空白にしておくこと
・R2は「=SUM(F2:Q2)」
・R3は「=SUM(F3:Q3)」
このボタンに以下のマクロを割り当てます。
' -----以下、ソース-----
Sub play()
Const OMOTE As Integer = 1
Const URA As Integer = 2
Dim inning As Integer
Dim uraomote As Integer
Dim gameset_flg As Integer
inning = Cells(1, 1)
uraomote = Cells(2, 1)
gameset_flg = Cells(3, 1)
Dim a As Integer
Dim b As Integer
Dim point As Integer
If gameset_flg = 1 Then
MsgBox ("ゲームセット！")
'初期化
gameset_flg = 0
Range(Cells(2, 6), Cells(3, 17)).ClearContents
Cells(1, 1) = 1
Cells(2, 1) = 1
Cells(3, 1) = 0
Else
more:
Randomize
a = Int(6 * Rnd + 1)
'MsgBox (a)
If a <= 2 Then
GoTo nxt
Else
b = Int(6 * Rnd + 1)
'MsgBox (b)
If a - b >= 1 Then
point = point + (a - b - 1)
If inning >= 9 And uraomote = URA Then
If Cells(2, 18) < Cells(3, 18) + point Then
Cells(uraomote + 1, inning + 5) = point
gameset_flg = 1
GoTo gameset
Else
End If
Else
End If
Else
End If
End If
nxt:
a = Int(6 * Rnd + 1)
'MsgBox (a)
If a = 1 Or a = 6 Then
GoTo more
Else
Cells(uraomote + 1, inning + 5) = point
If uraomote = OMOTE Then
Cells(2, 1) = URA
If inning = 9 Then
If Cells(2, 18) < Cells(3, 18) Then
uraomote = URA
Cells(uraomote + 1, inning + 5) = "X"
gameset_flg = 1
GoTo gameset
Else
End If
Else
End If
Else
Cells(1, 1) = inning + 1
Cells(2, 1) = OMOTE
If inning >= 9 And inning <= 11 Then
If Cells(2, 18) <> Cells(3, 18) Then
gameset_flg = 1
GoTo gameset
Else
End If
ElseIf inning = 12 Then
gameset_flg = 1
GoTo gameset
Else
End If
End If
End If
End If
gameset:
Cells(3, 1) = gameset_flg
End Sub
' -----以上、ソース-----
Sub play()
Const OMOTE As Integer = 1
Const URA As Integer = 2
Dim inning As Integer
Dim uraomote As Integer
Dim gameset_flg As Integer
inning = Cells(1, 1)
uraomote = Cells(2, 1)
gameset_flg = Cells(3, 1)
Dim a As Integer
Dim b As Integer
Dim point As Integer
If gameset_flg = 1 Then
MsgBox ("ゲームセット！")
'初期化
gameset_flg = 0
Range(Cells(2, 6), Cells(3, 17)).ClearContents
Cells(1, 1) = 1
Cells(2, 1) = 1
Cells(3, 1) = 0
Else
more:
Randomize
a = Int(6 * Rnd + 1)
'MsgBox (a)
If a <= 2 Then
GoTo nxt
Else
b = Int(6 * Rnd + 1)
'MsgBox (b)
If a - b >= 1 Then
point = point + (a - b - 1)
If inning >= 9 And uraomote = URA Then
If Cells(2, 18) < Cells(3, 18) + point Then
Cells(uraomote + 1, inning + 5) = point
gameset_flg = 1
GoTo gameset
Else
End If
Else
End If
Else
End If
End If
nxt:
a = Int(6 * Rnd + 1)
'MsgBox (a)
If a = 1 Or a = 6 Then
GoTo more
Else
Cells(uraomote + 1, inning + 5) = point
If uraomote = OMOTE Then
Cells(2, 1) = URA
If inning = 9 Then
If Cells(2, 18) < Cells(3, 18) Then
uraomote = URA
Cells(uraomote + 1, inning + 5) = "X"
gameset_flg = 1
GoTo gameset
Else
End If
Else
End If
Else
Cells(1, 1) = inning + 1
Cells(2, 1) = OMOTE
If inning >= 9 And inning <= 11 Then
If Cells(2, 18) <> Cells(3, 18) Then
gameset_flg = 1
GoTo gameset
Else
End If
ElseIf inning = 12 Then
gameset_flg = 1
GoTo gameset
Else
End If
End If
End If
End If
gameset:
Cells(3, 1) = gameset_flg
End Sub
' -----以上、ソース-----
いや、成長ですね。
■ 億劫なあとがき
遊びまで効率化！
ただ、遊びを効率化しちゃうと、本当にただの作業になってしまうという現実も知りました。。
