Excelのマクロでオセロを作ろう
はじめに
こんにちは!ふくぶちょ~です。
早速ですが皆さんは、Excelを使いこなせていますか?
僕は使いこなせていません。
機能多すぎだろ本当に。
実際本当に使いこなせてはいないのですが、マクロをある程度使える分、他の人よりは相対的に詳しい気はしてます。
皆さんもこの記事を読んでちょっとだけExcelに詳しい人になりましょう。
あと、僕は開発をあまりやらないので可読性などが終わってることに注意。
ExcelVBAの基礎知識
ぼくの書いた過去の記事を読んでみてください。
今回使う知識の大体のことは書いてあります。
技術系の記事を投稿するサイトにのせたものなので結構真面目に書いてあります。
オセロ板っぽいものを作ってみよう
まずはセルのサイズを正方形のように設定しましょう。
次のようになれば成功です。
次に8×8マスを選択し背景色を緑にして、セルの書式設定から線を引きましょう。
はい、これだけでそれっぽい感じになりましたね。
盤面を二次元配列で管理しよう
さてここからが本番です。
実際にどこに石が置かれているかを二次元配列に記録します。
計算の都合上黒色が置かれている時1、白色が置かれているとき-1、何もないとき0とします。
とりあえず開発タブからVBAを開いて標準モジュールを作成してください。
開発タブがない場合、過去の記事を参考にしてください。
そこに以下のコードを書き込んでください。
このコードでturnという整数の変数、memoという8×8の整数を持つ二次元配列を宣言しています。
Dim turn As Integer
Dim memo(8, 8) As Integer
オセロの石を置いてみよう
ではオセロの石を新しく二次元配列にセットするプロシージャを作ってみましょう。
putStoneプロシージャを呼ぶことでmemo配列のh行w列を更新することができます。
しかし、これだけでは内部データが変わっているだけで盤面に表示はされていません。
Sub putStone(ByVal h, ByVal w, ByVal stone_type)
memo(h, w) = stone_type
End Sub
次に、盤面更新のプロシージャを作成します。
これでは、最初盤面の図形をすべて削除します。
その後、二次元のループで二次元配列memoを全部みて、1が格納されていたら黒色の丸を記入、-1が格納されていたら白色の丸を記入しています。
AddShape以降の内容は図形の種類(msoShapeOvalは丸形)、位置、サイズに関わる部分、RGBと書いてあるところは色に関わる部分なので色々変えて遊んでみて下さい。
Sub display()
For Each a In ActiveSheet.Shapes
Debug.Print (a.AutoShapeType)
If a.AutoShapeType = msoShapeOval Then
a.Delete '丸形の図形を削除
End If
Next
Dim i, j As Integer
For i = 1 To 8
For j = 1 To 8
Dim sp As Shape
Dim h, w As Integer
If memo(i, j) = 1 Then
w = Cells(1, 1).Width
h = Cells(1, 1).Height
Set sp = ActiveSheet.Shapes.AddShape(msoShapeOval, (i - 1) * w + w / 10, (j - 1) * h + h / 10, w - w / 5, h - h / 5)
sp.Fill.ForeColor.RGB = RGB(0, 0, 0)
ElseIf memo(i, j) = -1 Then
w = Cells(1, 1).Width
h = Cells(1, 1).Height
Set sp = ActiveSheet.Shapes.AddShape(msoShapeOval, (i - 1) * w + w / 10, (j - 1) * h + h / 10, w - w / 5, h - h / 5)
sp.Fill.ForeColor.RGB = RGB(255, 255, 255)
End If
Next
Next
End Sub
実際に実行するためにプロシージャ(othelloSystemとreset)を作成しましょう。
othelloSystemは盤面を全部消し初期盤面を作成し表示するだけのプロシージャとなっておりresetプロシージャが盤面全消去を担っています。
Sub othelloSystem()
Call reset
Call putStone(4, 4, 1)
Call putStone(5, 5, 1)
Call putStone(4, 5, -1)
Call putStone(5, 4, -1)
Call display
End Sub
Sub reset()
Dim i, j As Integer
For i = 1 To 8
For j = 1 To 8
Call putStone(i, j, 0)
Next
Next
End Sub
あとはExcelシートからこのプロシージャを呼び出せるようにボタンを作りましょう。
ボタンは開発タブの挿入から行えます。
マクロの登録はothelloSystemにします。
あとはボタンを押せば盤面が完成します。
やったー!
クリックで石が置けるようにしよう
クリックで石を置けるようにしましょう。
そのためにまずは、以下の青で塗られているところを開きます。
これはExcelシートと一対一対応しているやつで、シート内をクリックをしたときに何かを起こすときはこちらを使うっぽいです。
このSheet1に以下のコードを記載します。
これは、クリックしたセルをTargetとして保持するプロシージャとなっており、内部でTargetの場所に石を置くプロシージャ(putStone)と盤面表示のプロシージャ(display)を呼んでいます。
Sub Worksheet_SelectionChange(ByVal Target As Range)
Call Module1.putStone(Target.Column, Target.Row, 1)
Call Module1.display
End Sub
しかしこれだけでは問題があります。
まずオセロ板を超えたところをクリックするとエラーになってしまうということです。
そのためこれを改善するためWorksheet_SelectionChangeプロシージャを変更します。
こうすることでクリックしたところとA1:H8(左上8×8マス)と共通部分がある時だけ石を置く操作が起動します。
Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("A1:H8")) Is Nothing Then
Call Module1.putStone(Target.Column, Target.Row, 1)
Call Module1.display
End If
End Sub
また、これだけだと黒石しか置けないのでターンに対応するように今までのコードを変更します。
まず、putStoneプロシージャの第三引数が変わっていてturnの変数を受け取っています(getTurn関数は未実装)。
そして最後に次のターンに移動しています(nextTurnプロシージャは未実装)
Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("A1:H8")) Is Nothing Then
Call Module1.putStone(Target.Column, Target.Row, Module1.getTurn)
Call Module1.display
Call Module1.nextTurn
End If
End Sub
今まで、Sheet1に書き込んでいましたがModule1に移ります。
ここにgetTurn関数とnextTurnプロシージャを書き込んでいきます。
Function getTurn() As Integer
getTurn = turn
End Function
Sub nextTurn()
turn = -turn
End Sub
最後に、othelloSystemプロシージャの最初にturn設定を追加します。
Sub othelloSystem()
turn = 1 '変更箇所
Call reset
Call putStone(4, 4, 1)
Call putStone(5, 5, 1)
Call putStone(4, 5, -1)
Call putStone(5, 4, -1)
Call display
End Sub
これで黒と白が交互に置けるようになりました!
やったね!
実際まだ既に石を置いた場所に置けてしまうなど困ったことはあるけど、それは次で解決します。
石が置ける場所を表示してみよう
ここからはちょっと複雑になります。
以下はi行j列目にstone_type(黒なら1、白なら-1)の石を置けるかどうかチェックする関数になっています。
考え方は移動を二次元ループで実行(上下方向に-1~1動くのと左右方向に-1~1動くのを組み合わせる)。
相手の石がその方向にあればそこからその方向に探索していき自分の石に当たれば置くことが可能とします。
Function putCheck(ByVal i, ByVal j, ByVal stone_type) As Boolean
'di,djはi,jの変化量(例えば1,1なら右下、1,0なら下方向)
Dim di, dj, k, l As Integer
Dim ok As Boolean
ok = False
'そのマスに石が置かれていたら置けない
If memo(i, j) <> 0 Then
putCheck = False
Exit Function
End If
For di = -1 To 1
For dj = -1 To 1
'変化量がともに0なら動かないのでスキップ
If di = 0 And dj = 0 Then
GoTo Continue
End If
'一歩進む
k = i + di
l = j + dj
'範囲を超えていたらスキップ
If k <= 0 Or k >= 9 Then
GoTo Continue
End If
If l <= 0 Or l >= 9 Then
GoTo Continue
End If
'stone_typeの石や空白ならスキップ
If memo(k, l) = stone_type Or memo(k, l) = 0 Then
GoTo Continue
End If
'一歩進む
k = k + di
l = l + dj
'以降stone_typeの石に至れば挟むことが可能で、置ける
'空白があればスキップ
While 1 <= k And k <= 8 And 1 <= l And l <= 8
If memo(k, l) = 0 Then
GoTo Continue
ElseIf memo(k, l) = stone_type Then
ok = True
GoTo Continue
End If
k = k + di
l = l + dj
Wend
Continue:
Next
Next
putCheck = ok
End Function
あとは置けないところをクリックしたときにメッセージを出すようにしてみましょう。
Sheet1の関数を変更します。
オセロのマス内をクリックした場合、置ける場合は置き、そうじゃない場合は警告文を出すようにします。
Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("A1:H8")) Is Nothing Then
If Module1.putCheck(Target.Column, Target.Row, Module1.getTurn) Then
Call Module1.putStone(Target.Column, Target.Row, Module1.getTurn)
Call Module1.display
Call Module1.nextTurn
Else
MsgBox ("そこには置けません!")
End If
End If
End Sub
だいぶオセロ感出てきましたね!
石をひっくり返そう
さて本番です。
オセロの一番重要な要素を実装しましょう。
実装法は概ね先ほどと同じです。
しかしこれが一番難しいと思います。
特に返り値がいらないので関数ではなくプロシージャにします。
Sub turnOver(ByVal i, ByVal j, ByVal stone_type)
'di,djはi,jの変化量(例えば1,1なら右下、1,0なら下方向)
Dim di, dj, k, l, p, q As Integer
For di = -1 To 1
For dj = -1 To 1
'変化量がともに0なら動かないのでスキップ
If di = 0 And dj = 0 Then
GoTo Continue
End If
'一歩進む
k = i + di
l = j + dj
'範囲を超えていたらスキップ
If k <= 0 Or k >= 9 Then
GoTo Continue
End If
If l <= 0 Or l >= 9 Then
GoTo Continue
End If
'stone_typeの石や空白ならスキップ
If memo(k, l) = stone_type Or memo(k, l) = 0 Then
GoTo Continue
End If
'一歩進む
k = k + di
l = l + dj
'以降stone_typeの石に至れば挟むことが可能で反転させる
'空白があればスキップ
While 1 <= k And k <= 8 And 1 <= l And l <= 8
If memo(k, l) = 0 Then
GoTo Continue
ElseIf memo(k, l) = stone_type Then
'挟めるので今までの道のりを再現して反転させる
p = i + di
q = j + dj
Debug.Print (p)
Debug.Print (q)
While p <> k Or q <> l
memo(p, q) = stone_type
p = p + di
q = q + dj
Wend
GoTo Continue
End If
k = k + di
l = l + dj
Wend
Continue:
Next
Next
End Sub
Sheet1の方も変更していきます。
Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("A1:H8")) Is Nothing Then
If Module1.putCheck(Target.Column, Target.Row, Module1.getTurn) Then
Call Module1.putStone(Target.Column, Target.Row, Module1.getTurn)
Call Module1.turnOver(Target.Column, Target.Row, Module1.getTurn)
Call Module1.display
Call Module1.nextTurn
Else
MsgBox ("そこには置けません!")
End If
End If
End Sub
ターンのスキップを実装しよう
実質ここまでで殆どオセロは完成しました。
あとは細部を調整していくだけです。
putCheck関数を利用してturnSkipCheck関数を用意します。
盤面全体でputCheck関数を走らせてどこも置くところがないならスキップを行います。
Function turnSkipCheck(ByVal stone_type) As Boolean
Dim i, j As Integer
Dim ok As Boolean
ok = True
For i = 1 To 8
For j = 1 To 8
If putCheck(i, j, stone_type) Then
ok = False
End If
Next
Next
turnSkipCheck = ok
End Function
Sheet1のほうも変更します。
Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("A1:H8")) Is Nothing Then
If Module1.putCheck(Target.Column, Target.Row, Module1.getTurn) Then
Call Module1.putStone(Target.Column, Target.Row, Module1.getTurn)
Call Module1.turnOver(Target.Column, Target.Row, Module1.getTurn)
Call Module1.display
Call Module1.nextTurn
Application.Wait [Now()] + 0.05 / 86400
If Module1.turnSkipCheck(Module1.getTurn) Then
MsgBox ("置くところがないのでターンスキップ!")
Call Module1.nextTurn
End If
Else
MsgBox ("そこには置けません!")
End If
End If
End Sub
置く場所がなくなったらちゃんと次のようにポップアップが出てターンが変わります。
Application.Wait [Now()] + 0.05 / 86400部分では0.05秒のwaitを行っています。
これはMsgBoxが盤面処理より早く出てしまうことがあったからです(ほかに解決法があれば教えてください)。
どちらのターンかわかりにくかったのでわかるように簡易的なプロシージャを作成しました。
Sub turnDisplay()
If turn = -1 Then
Cells(1, 9) = "白の番"
Cells(1, 9).Font.Color = RGB(0, 0, 0)
Cells(1, 9).Interior.Color = RGB(255, 255, 255)
ElseIf turn = 1 Then
Cells(1, 9) = "黒の番"
Cells(1, 9).Font.Color = RGB(255, 255, 255)
Cells(1, 9).Interior.Color = RGB(0, 0, 0)
End If
End Sub
この導入のためいくつか変更を施しました。
Sub othelloSystem()
turn = 1
Call reset
Call putStone(4, 4, 1)
Call putStone(5, 5, 1)
Call putStone(4, 5, -1)
Call putStone(5, 4, -1)
Call display
Call turnDisplay '変更箇所
End Sub
Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("A1:H8")) Is Nothing Then
If Module1.putCheck(Target.Column, Target.Row, Module1.getTurn) Then
Call Module1.putStone(Target.Column, Target.Row, Module1.getTurn)
Call Module1.turnOver(Target.Column, Target.Row, Module1.getTurn)
Call Module1.nextTurn
Call Module1.display
Call Module1.turnDisplay
Application.Wait [Now()] + 0.05 / 86400
If Module1.turnSkipCheck(Module1.getTurn) Then
Call Module1.nextTurn'変更箇所
Call Module1.turnDisplay'変更箇所
MsgBox ("置くところがないのでターンスキップ!")'変更箇所
End If
Else
MsgBox ("そこには置けません!")
End If
End If
End Sub
ちゃんと黒を置いた後ですがターンスキップが起きたので次も黒です。
ゲーム終了を判定してみよう
実際さっきの例だとターンスキップどころかゲーム終了です。
そこを実装していきます。
黒も白の両方置くところがない場合終了であり、これは先ほどのturnSkipCheckを再利用します。
Worksheet_SelectionChangeを変更しましょう。
Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("A1:H8")) Is Nothing Then
If Module1.putCheck(Target.Column, Target.Row, Module1.getTurn) Then
Call Module1.putStone(Target.Column, Target.Row, Module1.getTurn)
Call Module1.turnOver(Target.Column, Target.Row, Module1.getTurn)
Call Module1.nextTurn
Call Module1.display
Call Module1.turnDisplay
Application.Wait [Now()] + 0.05 / 86400
If Module1.turnSkipCheck(-1) And Module1.turnSkipCheck(1) Then
Call Module1.gameSet
Exit Sub
End If
If Module1.turnSkipCheck(Module1.getTurn) Then
Call Module1.nextTurn
Call Module1.turnDisplay
MsgBox ("置くところがないのでターンスキップ!")
End If
Else
MsgBox ("そこには置けません!")
End If
End If
End Sub
gameSetプロシージャを実装します。
ここでは石の数を数えて出力します。
Sub gameSet()
Dim b, w As Integer
Dim i, j As Integer
b = 0
w = 0
For i = 1 To 8
For j = 1 To 8
If memo(i, j) = 1 Then
b = b + 1
ElseIf memo(i, j) = -1 Then
w = w + 1
End If
Next
Next
MsgBox ("ゲーム終了!" & vbCrLf & "黒:" & b & vbCrLf & "白:" & w)
End Sub
YEAH!!!
謝罪
初期盤面間違えてたわ。
Sub othelloSystem()
turn = 1
Call reset
Call putStone(4, 4, -1)
Call putStone(5, 5, -1)
Call putStone(4, 5, 1)
Call putStone(5, 4, 1)
Call display
Call turnDisplay
End Sub
最後に
まだまだ改良の余地はあるので色々やってみてね!
Excelファイル
実際のファイルを載せておきます。
一応大丈夫だと思いますが、これの使用によって何かしら被害を被ったとしても自己責任ということでお願いします。
コードなど
Module1内のコード
Dim turn As Integer
Dim memo(8, 8) As Integer
Sub putStone(ByVal h, ByVal w, ByVal stone_type)
memo(h, w) = stone_type
End Sub
Sub turnDisplay()
If turn = -1 Then
Cells(1, 9) = "白の番"
Cells(1, 9).Font.Color = RGB(0, 0, 0)
Cells(1, 9).Interior.Color = RGB(255, 255, 255)
ElseIf turn = 1 Then
Cells(1, 9) = "黒の番"
Cells(1, 9).Font.Color = RGB(255, 255, 255)
Cells(1, 9).Interior.Color = RGB(0, 0, 0)
End If
End Sub
Sub display()
For Each a In ActiveSheet.Shapes
Debug.Print (a.AutoShapeType)
If a.AutoShapeType = msoShapeOval Then
a.Delete '丸形の図形を削除
End If
Next
Dim i, j As Integer
For i = 1 To 8
For j = 1 To 8
Dim sp As Shape
Dim h, w As Integer
If memo(i, j) = 1 Then
w = Cells(1, 1).Width
h = Cells(1, 1).Height
Set sp = ActiveSheet.Shapes.AddShape(msoShapeOval, (i - 1) * w + w / 10, (j - 1) * h + h / 10, w - w / 5, h - h / 5)
sp.Fill.ForeColor.RGB = RGB(0, 0, 0)
ElseIf memo(i, j) = -1 Then
w = Cells(1, 1).Width
h = Cells(1, 1).Height
Set sp = ActiveSheet.Shapes.AddShape(msoShapeOval, (i - 1) * w + w / 10, (j - 1) * h + h / 10, w - w / 5, h - h / 5)
sp.Fill.ForeColor.RGB = RGB(255, 255, 255)
End If
Next
Next
End Sub
Sub othelloSystem()
turn = 1
Call reset
Call putStone(4, 4, -1)
Call putStone(5, 5, -1)
Call putStone(4, 5, 1)
Call putStone(5, 4, 1)
Call display
Call turnDisplay
End Sub
Sub reset()
Dim i, j As Integer
For i = 1 To 8
For j = 1 To 8
Call putStone(i, j, 0)
Next
Next
End Sub
Function getTurn() As Integer
getTurn = turn
End Function
Sub nextTurn()
turn = -turn
End Sub
Function putCheck(ByVal i, ByVal j, ByVal stone_type) As Boolean
'di,djはi,jの変化量(例えば1,1なら右下、1,0なら下方向)
Dim di, dj, k, l As Integer
Dim h, w As Integer
Dim ok As Boolean
ok = False
'そのマスに石が置かれていたら置けない
If memo(i, j) <> 0 Then
putCheck = False
Exit Function
End If
For di = -1 To 1
For dj = -1 To 1
'変化量がともに0なら動かないのでスキップ
If di = 0 And dj = 0 Then
GoTo Continue
End If
'一歩進む
k = i + di
l = j + dj
'範囲を超えていたらスキップ
If k <= 0 Or k >= 9 Then
GoTo Continue
End If
If l <= 0 Or l >= 9 Then
GoTo Continue
End If
'stone_typeの石や空白ならスキップ
If memo(k, l) = stone_type Or memo(k, l) = 0 Then
GoTo Continue
End If
'一歩進む
k = k + di
l = l + dj
'以降stone_typeの石に至れば挟むことが可能で、置ける
'空白があればスキップ
While 1 <= k And k <= 8 And 1 <= l And l <= 8
If memo(k, l) = 0 Then
GoTo Continue
ElseIf memo(k, l) = stone_type Then
ok = True
GoTo Continue
End If
k = k + di
l = l + dj
Wend
Continue:
Next
Next
putCheck = ok
End Function
Sub turnOver(ByVal i, ByVal j, ByVal stone_type)
'di,djはi,jの変化量(例えば1,1なら右下、1,0なら下方向)
Dim di, dj, k, l, p, q As Integer
For di = -1 To 1
For dj = -1 To 1
'変化量がともに0なら動かないのでスキップ
If di = 0 And dj = 0 Then
GoTo Continue
End If
'一歩進む
k = i + di
l = j + dj
'範囲を超えていたらスキップ
If k <= 0 Or k >= 9 Then
GoTo Continue
End If
If l <= 0 Or l >= 9 Then
GoTo Continue
End If
'stone_typeの石や空白ならスキップ
If memo(k, l) = stone_type Or memo(k, l) = 0 Then
GoTo Continue
End If
'一歩進む
k = k + di
l = l + dj
'以降stone_typeの石に至れば挟むことが可能で反転させる
'空白があればスキップ
While 1 <= k And k <= 8 And 1 <= l And l <= 8
If memo(k, l) = 0 Then
GoTo Continue
ElseIf memo(k, l) = stone_type Then
'挟めるので今までの道のりを再現して反転させる
p = i + di
q = j + dj
Debug.Print (p)
Debug.Print (q)
While p <> k Or q <> l
memo(p, q) = stone_type
p = p + di
q = q + dj
Wend
GoTo Continue
End If
k = k + di
l = l + dj
Wend
Continue:
Next
Next
End Sub
Function turnSkipCheck(ByVal stone_type) As Boolean
Dim i, j As Integer
Dim ok As Boolean
ok = True
For i = 1 To 8
For j = 1 To 8
If putCheck(i, j, stone_type) Then
ok = False
End If
Next
Next
turnSkipCheck = ok
End Function
Sub gameSet()
Dim b, w As Integer
Dim i, j As Integer
b = 0
w = 0
For i = 1 To 8
For j = 1 To 8
If memo(i, j) = 1 Then
b = b + 1
ElseIf memo(i, j) = -1 Then
w = w + 1
End If
Next
Next
MsgBox ("ゲーム終了!" & vbCrLf & "黒:" & b & vbCrLf & "白:" & w)
End Sub
Sheet1内のコード
Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("A1:H8")) Is Nothing Then
If Module1.putCheck(Target.Column, Target.Row, Module1.getTurn) Then
Call Module1.putStone(Target.Column, Target.Row, Module1.getTurn)
Call Module1.turnOver(Target.Column, Target.Row, Module1.getTurn)
Call Module1.nextTurn
Call Module1.display
Call Module1.turnDisplay
Application.Wait [Now()] + 0.05 / 86400
If Module1.turnSkipCheck(-1) And Module1.turnSkipCheck(1) Then
Call Module1.gameSet
Exit Sub
End If
If Module1.turnSkipCheck(Module1.getTurn) Then
Call Module1.nextTurn
Call Module1.turnDisplay
MsgBox ("置くところがないのでターンスキップ!")
End If
Else
MsgBox ("そこには置けません!")
End If
End If
End Sub
この記事が気に入ったらサポートをしてみませんか?