LoginSignup
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

More than 1 year has passed since last update.

@sano192

『Excelでリバーシを作ろう！　マクロ、VBAを1から学ぶ』コピペ用コード　リバーシ

Last updated at Posted at 2022-04-09

『Excelでリバーシを作ろう!!　マクロ、VBAを1から学ぶ』内で使用しているコードです。

Excelのマクロ(VBA)で「三目並べ」「マインスイーパー」「リバーシ」を作る解説本です！
プログラミングが全くわからない人でも大丈夫！　丁寧な解説と図でしっかり理解しながら楽しくプログラミングを学ぶ事ができます！
値段：300円(Kindle Unlimited対象)

【kindle】

【booth(pdf】

「三目並べ」
https://qiita.com/sano192/items/1f674361711114d57b91
「マインスイーパー」
https://qiita.com/sano192/items/8eee84c6cd86db7d9a43

「リバーシ 2」

「リバーシ 2」
Sub GameStart()
   
'    盤面に入力されているものをクリア
    Range("B2", "I9").ClearContents
   
'    石の配置
    Cells(5, 5) = "○"
    Cells(5, 6) = "●"
    Cells(6, 5) = "●"
    Cells(6, 6) = "○"
   
'    手番を表示
    Cells(2, 11) = "黒の番"
   
'    石の個数を表示
    Cells(3, 13) = 2
    Cells(4, 13) = 2
   
'    盤外を選択状態にする
    Cells(2, 11).Select
   
End Sub

「リバーシ 3」

「リバーシ 3」
Sub GameStart()
   
'    盤面に入力されているものをクリア
    Range("B2", "I9").ClearContents
   
'    石の配置
    Cells(5, 5) = "○"
    Cells(5, 6) = "●"
    Cells(6, 5) = "●"
    Cells(6, 6) = "○"
   
'    手番を表示
    Cells(2, 11) = "黒の番"
   
'    石の個数を表示
    Cells(3, 13) = 2
    Cells(4, 13) = 2
   
'    盤外を選択状態にする
    Cells(2, 11).Select
   
End Sub
 
'手番の石の色を確認する処理
Function SearchMyStone()
 
'    盤面の背景色を白に設定
    Range("B2", "I9").Interior.Color = RGB(255, 255, 255)
   
    Dim MyStone
   
'    手番の色
    MyStone = CheckMyStone
   
'    手番の色の石を探す
    For Gyou = 2 To 9
        For Retu = 2 To 9
           
            If Cells(Gyou, Retu) = MyStone Then
                「8方向に探索して着手可能マスに色を塗る処理」
            End If
           
        Next Retu
    Next Gyou
   
End Function
 
'手番の色の石を確認する処理
Function CheckMyStone
 
    If Cells(2, 11) = "黒の番" Then
        CheckMyStone = "●"
    ElseIf Cells(2, 11) = "白の番" Then
        CheckMyStone = "○"
    End If
   
End Function

「リバーシ 4」

「リバーシ 4」
Sub GameStart()
   
'    盤面に入力されているものをクリア
    Range("B2", "I9").ClearContents
   
'    石の配置
    Cells(5, 5) = "○"
    Cells(5, 6) = "●"
    Cells(6, 5) = "●"
    Cells(6, 6) = "○"
   
'    手番を表示
    Cells(2, 11) = "黒の番"
   
'    石の個数を表示
    Cells(3, 13) = 2
    Cells(4, 13) = 2
   
'    盤外を選択状態にする
    Cells(2, 11).Select
   
    Call SearchMyStone
   
End Sub
 
'手番の色の石を探す処理
Function SearchMyStone()
 
'    盤面の背景色を白に設定
    Range("B2", "I9").Interior.Color = RGB(255, 255, 255)
   
    Dim MyStone
   
'    手番の色
    MyStone = CheckMyStone
   
'    手番の色の石を探す
    For Gyou = 2 To 9
        For Retu = 2 To 9
           
            If Cells(Gyou, Retu) = MyStone Then
'                8方向について処理
                For y = -1 To 1
                    For x = -1 To 1
                        Call LegalSquareColor(Gyou, Retu, y, x)
                    Next x
                Next y
            End If
           
        Next Retu
    Next Gyou
   
End Function
 
'手番の石の色を確認する処理
Function CheckMyStone()
 
    If Cells(2, 11) = "黒の番" Then
        CheckMyStone = "●"
    ElseIf Cells(2, 11) = "白の番" Then
        CheckMyStone = "○"
    End If
   
End Function
 
'着手可能なマスに色をつける処理
'引数：起点となる石の行番号,起点となる石の列番号,上下方向,左右方向
Function LegalSquareColor(Gyou, Retu, Gd, Rd)
   
'    方向が両方0なら終了
    If Gd = 0 And Rd = 0 Then
        Exit Function
    End If
 
    Dim MyStone, OpStone
   
    MyStone = CheckMyStone
    OpStone = CheckOpStone
   
'    一つ移動したマスが「敵の石」なら
    If Cells(Gyou + Gd, Retu + Rd) = OpStone Then
   
'        i個移動したマスを探索
        For i = 2 To 8
'            i個移動したマスが盤面の範囲内に収まっているか=「壁」でないか
            If CheckInBoard(Gyou + Gd * i, Retu + Rd * i) = True Then
           
'                i個移動したマスが「空白」
                If Cells(Gyou + Gd * i, Retu + Rd * i) = "" Then
'                    色をつける
                    Cells(Gyou + Gd * i, Retu + Rd * i).Interior.Color = RGB(219, 190, 107)
'                    関数を終了
                    Exit For
   
'                i個移動したマスが「自分の石」
                ElseIf Cells(Gyou + Gd * i, Retu + Rd * i) = MyStone Then
'                    関数を終了
                    Exit For
                   
                End If
               
'            i個移動したマスが盤面の範囲内に収まっていない=「壁」
            Else
'                関数を終了
                Exit For
   
            End If
           
        Next i
   
    End If
 
End Function

'手番でない石の色を確認する処理
Function CheckOpStone()
 
    If Cells(2, 11) = "黒の番" Then
        CheckOpStone = "○"
    ElseIf Cells(2, 11) = "白の番" Then
        CheckOpStone = "●"
    End If
 
End Function
 
'行番号,列番号が盤面の範囲内に収まっているか確認
Function CheckInBoard(Gyou, Retu)
 
    If Gyou < 2 Or 9 < Gyou Or Retu < 2 Or 9 < Retu Then
        CheckInBoard = False
    Else
        CheckInBoard = True
    End If
   
End Function

「リバーシ 5」

「リバーシ 5」
Sub GameStart()
   
'    盤面に入力されているものをクリア
    Range("B2", "I9").ClearContents
   
'    石の配置
    Cells(5, 5) = "○"
    Cells(5, 6) = "●"
    Cells(6, 5) = "●"
    Cells(6, 6) = "○"
   
'    手番を表示
    Cells(2, 11) = "黒の番"
   
'    石の個数を表示
    Cells(3, 13) = 2
    Cells(4, 13) = 2
   
'    盤外を選択状態にする
    Cells(2, 11).Select
   
    Call SearchMyStone
   
End Sub
 
'手番の色の石を探す処理
Function SearchMyStone()
 
'    盤面の背景色を白に設定
    Range("B2", "I9").Interior.Color = RGB(255, 255, 255)
   
    Dim MyStone
   
'    手番の色
    MyStone = CheckMyStone
   
'    手番の色の石を探す
    For Gyou = 2 To 9
        For Retu = 2 To 9
           
            If Cells(Gyou, Retu) = MyStone Then
'                8方向について処理
                For y = -1 To 1
                    For x = -1 To 1
                        Call LegalSquareColor(Gyou, Retu, y, x)
                    Next x
                Next y
            End If
           
        Next Retu
    Next Gyou
   
End Function
 
'手番の石の色を確認する処理
Function CheckMyStone()
 
    If Cells(2, 11) = "黒の番" Then
        CheckMyStone = "●"
    ElseIf Cells(2, 11) = "白の番" Then
        CheckMyStone = "○"
    End If
   
End Function
 
'着手可能なマスに色をつける処理
'引数：起点となる石の行番号,起点となる石の列番号,上下方向,左右方向
Function LegalSquareColor(Gyou, Retu, Gd, Rd)
   
'    方向が両方0なら終了
    If Gd = 0 And Rd = 0 Then
        Exit Function
    End If
 
    Dim MyStone, OpStone
   
    MyStone = CheckMyStone
    OpStone = CheckOpStone
   
'    一つ移動したマスが「敵の石」なら
    If Cells(Gyou + Gd, Retu + Rd) = OpStone Then
   
'        i個移動したマスを探索
        For i = 2 To 8
'            i個移動したマスが盤面の範囲内に収まっているか=「壁」でないか
            If CheckInBoard(Gyou + Gd * i, Retu + Rd * i) = True Then
           
'                i個移動したマスが「空白」
                If Cells(Gyou + Gd * i, Retu + Rd * i) = "" Then
'                    色をつける
                    Cells(Gyou + Gd * i, Retu + Rd * i).Interior.Color = RGB(219, 190, 107)
'                    関数を終了
                    Exit For
   
'                i個移動したマスが「自分の石」
                ElseIf Cells(Gyou + Gd * i, Retu + Rd * i) = MyStone Then
'                    関数を終了
                    Exit For
                   
                End If
               
'            i個移動したマスが盤面の範囲内に収まっていない=「壁」
            Else
'                関数を終了
                Exit For
   
            End If
           
        Next i
   
    End If
 
End Function

'手番でない石の色を確認する処理
Function CheckOpStone()
 
    If Cells(2, 11) = "黒の番" Then
        CheckOpStone = "○"
    ElseIf Cells(2, 11) = "白の番" Then
        CheckOpStone = "●"
    End If
 
End Function
 
'行番号,列番号が盤面の範囲内に収まっているか確認
Function CheckInBoard(Gyou, Retu)
 
    If Gyou < 2 Or 9 < Gyou Or Retu < 2 Or 9 < Retu Then
        CheckInBoard = False
    Else
        CheckInBoard = True
    End If
   
End Function

'クリックしたときの処理
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
'    ゲームが終了している場合
    If Cells(2, 11) = "黒の勝ち" Or Cells(2, 11) = "白の勝ち" Or Cells(2, 11) = "引き分け" Then
        Exit Sub
    End If
   
    Dim Gyou, Retu, MyStone
   
'    クリックしたセルの行番号,列番号
    Gyou = Target.Row
    Retu = Target.Column
   
'    着手可能なマスでなければ
    If Cells(Gyou, Retu).Interior.Color <> RGB(219, 190, 107) Then
        Exit Sub
    End If
   
    MyStone = CheckMyStone
   
'    「手番の色の石」を入力
    Cells(Gyou, Retu) = MyStone
 
End Sub

「リバーシ 6」

「リバーシ 6」
Sub GameStart()
   
'    盤面に入力されているものをクリア
    Range("B2", "I9").ClearContents
   
'    石の配置
    Cells(5, 5) = "○"
    Cells(5, 6) = "●"
    Cells(6, 5) = "●"
    Cells(6, 6) = "○"
   
'    手番を表示
    Cells(2, 11) = "黒の番"
   
'    石の個数を表示
    Cells(3, 13) = 2
    Cells(4, 13) = 2
   
'    盤外を選択状態にする
    Cells(2, 11).Select
   
    Call SearchMyStone
   
End Sub
 
'手番の色の石を探す処理
Function SearchMyStone()
 
'    盤面の背景色を白に設定
    Range("B2", "I9").Interior.Color = RGB(255, 255, 255)
   
    Dim MyStone
   
'    手番の色
    MyStone = CheckMyStone
   
'    手番の色の石を探す
    For Gyou = 2 To 9
        For Retu = 2 To 9
           
            If Cells(Gyou, Retu) = MyStone Then
'                8方向について処理
                For y = -1 To 1
                    For x = -1 To 1
                        Call LegalSquareColor(Gyou, Retu, y, x)
                    Next x
                Next y
            End If
           
        Next Retu
    Next Gyou
   
End Function
 
'手番の石の色を確認する処理
Function CheckMyStone()
 
    If Cells(2, 11) = "黒の番" Then
        CheckMyStone = "●"
    ElseIf Cells(2, 11) = "白の番" Then
        CheckMyStone = "○"
    End If
   
End Function
 
'着手可能なマスに色をつける処理
'引数：起点となる石の行番号,起点となる石の列番号,上下方向,左右方向
Function LegalSquareColor(Gyou, Retu, Gd, Rd)
   
'    方向が両方0なら終了
    If Gd = 0 And Rd = 0 Then
        Exit Function
    End If
 
    Dim MyStone, OpStone
   
    MyStone = CheckMyStone
    OpStone = CheckOpStone
   
'    一つ移動したマスが「敵の石」なら
    If Cells(Gyou + Gd, Retu + Rd) = OpStone Then
   
'        i個移動したマスを探索
        For i = 2 To 8
'            i個移動したマスが盤面の範囲内に収まっているか=「壁」でないか
            If CheckInBoard(Gyou + Gd * i, Retu + Rd * i) = True Then
           
'                i個移動したマスが「空白」
                If Cells(Gyou + Gd * i, Retu + Rd * i) = "" Then
'                    色をつける
                    Cells(Gyou + Gd * i, Retu + Rd * i).Interior.Color = RGB(219, 190, 107)
'                    関数を終了
                    Exit For
   
'                i個移動したマスが「自分の石」
                ElseIf Cells(Gyou + Gd * i, Retu + Rd * i) = MyStone Then
'                    関数を終了
                    Exit For
                   
                End If
               
'            i個移動したマスが盤面の範囲内に収まっていない=「壁」
            Else
'                関数を終了
                Exit For
   
            End If
           
        Next i
   
    End If
 
End Function

'手番でない石の色を確認する処理
Function CheckOpStone()
 
    If Cells(2, 11) = "黒の番" Then
        CheckOpStone = "○"
    ElseIf Cells(2, 11) = "白の番" Then
        CheckOpStone = "●"
    End If
 
End Function
 
'行番号,列番号が盤面の範囲内に収まっているか確認
Function CheckInBoard(Gyou, Retu)
 
    If Gyou < 2 Or 9 < Gyou Or Retu < 2 Or 9 < Retu Then
        CheckInBoard = False
    Else
        CheckInBoard = True
    End If
   
End Function
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
'    ゲームが終了している場合
    If Cells(2, 11) = "黒の勝ち" Or Cells(2, 11) = "白の勝ち" Or Cells(2, 11) = "引き分け" Then
        Exit Sub
    End If
   
    Dim Gyou, Retu, MyStone
   
'    クリックしたセルの行番号,列番号
    Gyou = Target.Row
    Retu = Target.Column
   
'    着手可能なマスでなければ
    If Cells(Gyou, Retu).Interior.Color <> RGB(219, 190, 107) Then
        Exit Sub
    End If
   
    MyStone = CheckMyStone
   
'    「手番の色の石」を入力
    Cells(Gyou, Retu) = MyStone
   
    For y = -1 To 1
        For x = -1 To 1
            Call TurnOver(Gyou, Retu, y, x)
        Next x
    Next y
 
End Sub
 
'ひっくり返す処理
Function TurnOver(Gyou, Retu, Gd, Rd)
 
    If Gd = 0 And Rd = 0 Then
        Exit Function
    End If
 
    Dim MyStone, OpStone
 
    MyStone = CheckMyStone
    OpStone = CheckOpStone
   
'    一つ移動したマスが「敵の石なら」
    If Cells(Gyou + Gd, Retu + Rd) = OpStone Then
   
'        i個移動したマスを探索
        For i = 2 To 8
       
'            i個移動したマスが盤面の範囲内に収まっているか = 壁でないか
            If CheckInBoard(Gyou + Gd * i, Retu + Rd * i) Then
               
'                i個移動したマスが「空白」
                If Cells(Gyou + Gd * i, Retu + Rd * i) = "" Then
'                    関数を終了
                    Exit For
           
'                i個移動したマスが「自分の石」
                ElseIf Cells(Gyou + Gd * i, Retu + Rd * i) = MyStone Then
                   
'                    k=1~(i-1)
                    For k = 1 To i - 1
'                        「自分の石」へ変更
                        Cells(Gyou + Gd * k, Retu + Rd * k) = MyStone
                    Next k
                   
'                    関数を終了
                    Exit For
                   
                End If
               
'            i個移動したマスが盤面の範囲内に収まっていない=「壁」
            Else
                Exit For
               
            End If
               
        Next i
       
    End If
   
End Function

「リバーシ 7」

「リバーシ 7」
Sub GameStart()
   
'    盤面に入力されているものをクリア
    Range("B2", "I9").ClearContents
   
'    石の配置
    Cells(5, 5) = "○"
    Cells(5, 6) = "●"
    Cells(6, 5) = "●"
    Cells(6, 6) = "○"
   
'    手番を表示
    Cells(2, 11) = "黒の番"
   
'    石の個数を表示
    Cells(3, 13) = 2
    Cells(4, 13) = 2
   
'    盤外を選択状態にする
    Cells(2, 11).Select
   
    Call SearchMyStone
   
End Sub
 
'手番の色の石を探す処理
Function SearchMyStone()
 
'    盤面の背景色を白に設定
    Range("B2", "I9").Interior.Color = RGB(255, 255, 255)
   
    Dim MyStone
   
'    手番の色
    MyStone = CheckMyStone
   
'    手番の色の石を探す
    For Gyou = 2 To 9
        For Retu = 2 To 9
           
            If Cells(Gyou, Retu) = MyStone Then
'                8方向について処理
                For y = -1 To 1
                    For x = -1 To 1
                        Call LegalSquareColor(Gyou, Retu, y, x)
                    Next x
                Next y
            End If
           
        Next Retu
    Next Gyou
   
End Function
 
'手番の石の色を確認する処理
Function CheckMyStone()
 
    If Cells(2, 11) = "黒の番" Then
        CheckMyStone = "●"
    ElseIf Cells(2, 11) = "白の番" Then
        CheckMyStone = "○"
    End If
   
End Function
 
'着手可能なマスに色をつける処理
'引数：起点となる石の行番号,起点となる石の列番号,上下方向,左右方向
Function LegalSquareColor(Gyou, Retu, Gd, Rd)
   
'    方向が両方0なら終了
    If Gd = 0 And Rd = 0 Then
        Exit Function
    End If
 
    Dim MyStone, OpStone
   
    MyStone = CheckMyStone
    OpStone = CheckOpStone
   
'    一つ移動したマスが「敵の石」なら
    If Cells(Gyou + Gd, Retu + Rd) = OpStone Then
   
'        i個移動したマスを探索
        For i = 2 To 8
'            i個移動したマスが盤面の範囲内に収まっているか=「壁」でないか
            If CheckInBoard(Gyou + Gd * i, Retu + Rd * i) = True Then
           
'                i個移動したマスが「空白」
                If Cells(Gyou + Gd * i, Retu + Rd * i) = "" Then
'                    色をつける
                    Cells(Gyou + Gd * i, Retu + Rd * i).Interior.Color = RGB(219, 190, 107)
'                    関数を終了
                    Exit For
   
'                i個移動したマスが「自分の石」
                ElseIf Cells(Gyou + Gd * i, Retu + Rd * i) = MyStone Then
'                    関数を終了
                    Exit For
                   
                End If
               
'            i個移動したマスが盤面の範囲内に収まっていない=「壁」
            Else
'                関数を終了
                Exit For
   
            End If
           
        Next i
   
    End If
 
End Function

'手番でない石の色を確認する処理
Function CheckOpStone()
 
    If Cells(2, 11) = "黒の番" Then
        CheckOpStone = "○"
    ElseIf Cells(2, 11) = "白の番" Then
        CheckOpStone = "●"
    End If
 
End Function
 
'行番号,列番号が盤面の範囲内に収まっているか確認
Function CheckInBoard(Gyou, Retu)
 
    If Gyou < 2 Or 9 < Gyou Or Retu < 2 Or 9 < Retu Then
        CheckInBoard = False
    Else
        CheckInBoard = True
    End If
   
End Function
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
'    ゲームが終了している場合
    If Cells(2, 11) = "黒の勝ち" Or Cells(2, 11) = "白の勝ち" Or Cells(2, 11) = "引き分け" Then
        Exit Sub
    End If
   
    Dim Gyou, Retu, MyStone
   
'    クリックしたセルの行番号,列番号
    Gyou = Target.Row
    Retu = Target.Column
   
'    着手可能なマスでなければ
    If Cells(Gyou, Retu).Interior.Color <> RGB(219, 190, 107) Then
        Exit Sub
    End If
   
    MyStone = CheckMyStone
   
'    「手番の色の石」を入力
    Cells(Gyou, Retu) = MyStone
   
    For y = -1 To 1
        For x = -1 To 1
            Call TurnOver(Gyou, Retu, y, x)
        Next x
    Next y
   
'    石を数える
    Call CountStone
   
'    勝敗判定/手番変更
    Call CheckEnd
 
End Sub
 
'ひっくり返す処理
Function TurnOver(Gyou, Retu, Gd, Rd)
 
    If Gd = 0 And Rd = 0 Then
        Exit Function
    End If
 
    Dim MyStone, OpStone
 
    MyStone = CheckMyStone
    OpStone = CheckOpStone
   
'    一つ移動したマスが「敵の石なら」
    If Cells(Gyou + Gd, Retu + Rd) = OpStone Then
   
'        i個移動したマスを探索
        For i = 2 To 8
       
'            i個移動したマスが盤面の範囲内に収まっているか = 壁でないか
            If CheckInBoard(Gyou + Gd * i, Retu + Rd * i) Then
               
'                i個移動したマスが「空白」
                If Cells(Gyou + Gd * i, Retu + Rd * i) = "" Then
'                    関数を終了
                    Exit For
           
'                i個移動したマスが「自分の石」
                ElseIf Cells(Gyou + Gd * i, Retu + Rd * i) = MyStone Then
                   
'                    k=1~(i-1)
                    For k = 1 To i - 1
'                        「自分の石」へ変更
                        Cells(Gyou + Gd * k, Retu + Rd * k) = MyStone
                    Next k
                   
'                    関数を終了
                    Exit For
                   
                End If
               
'            i個移動したマスが盤面の範囲内に収まっていない=「壁」
            Else
                Exit For
               
            End If
               
        Next i
       
    End If
   
End Function
 
'石を数える処理
Function CountStone()
 
    Dim BlackCount, WhiteCount, Gyou, Retu
   
'    黒石、白石の数
    BlackCount = 0
    WhiteCount = 0
   
'    盤面の全てのマスを確認して数える
    For Gyou = 2 To 9
        For Retu = 2 To 9
 
            If Cells(Gyou, Retu) = "●" Then
                BlackCount = BlackCount + 1
 
            ElseIf Cells(Gyou, Retu) = "○" Then
                WhiteCount = WhiteCount + 1
 
            End If
 
        Next Retu
    Next Gyou
   
'    個数を入力
    Cells(3, 13) = BlackCount
    Cells(4, 13) = WhiteCount
   
End Function
 
'合法手があるか確認する処理
Function CheckLegalExist()
 
    For Gyou = 2 To 9
        For Retu = 2 To 9
'            背景色がついているマスが存在する場合
            If Cells(Gyou, Retu).Interior.Color = RGB(219, 190, 107) Then
                CheckLegalExist = True
                Exit Function
            End If
           
        Next Retu
    Next Gyou
 
'    背景色がついているマスが存在しない場合
    CheckLegalExist = False
 
End Function
 
'手番を変更する処理
Function ChangeTurn()
 
    If Cells(2, 11) = "黒の番" Then
        Cells(2, 11) = "白の番"
    ElseIf Cells(2, 11) = "白の番" Then
        Cells(2, 11) = "黒の番"
    End If
   
End Function
 
'勝敗判定/手番変更
Function CheckEnd()
   
'    手番の変更
    Call ChangeTurn
   
'    着手可能なマスに色をつける
    Call SearchMyStone
   
'    着手可能なマスがあれば処理終了
    If CheckLegalExist = True Then
        Exit Function
    End If
 
'    手番の変更
    Call ChangeTurn
   
'    着手可能なマスに色をつける
    Call SearchMyStone
   
'    着手可能なマスがあれば処理終了
    If CheckLegalExist = True Then
        Exit Function
    End If
   
'    双方置く場所がないので勝敗の判定
    If Cells(3, 13) < Cells(4, 13) Then
        Cells(2, 11) = "白の勝ち"
    ElseIf Cells(4, 13) < Cells(3, 13) Then
        Cells(2, 11) = "黒の勝ち"
    Else
        Cells(2, 11) = "引き分け"
    End If
   
End Function

「リバーシ コード全文」

「リバーシ コード全文」
Sub GameStart()
   
'    盤面に入力されているものをクリア
    Range("B2", "I9").ClearContents
   
'    石の配置
    Cells(5, 5) = "○"
    Cells(5, 6) = "●"
    Cells(6, 5) = "●"
    Cells(6, 6) = "○"
   
'    手番を表示
    Cells(2, 11) = "黒の番"
   
'    石の個数を表示
    Cells(3, 13) = 2
    Cells(4, 13) = 2
   
'    盤外を選択状態にする
    Cells(2, 11).Select
   
    Call SearchMyStone
   
End Sub
 
'手番の色の石を探す処理
Function SearchMyStone()
 
'    盤面の背景色を白に設定
    Range("B2", "I9").Interior.Color = RGB(255, 255, 255)
   
    Dim MyStone
   
'    手番の色
    MyStone = CheckMyStone
   
'    手番の色の石を探す
    For Gyou = 2 To 9
        For Retu = 2 To 9
           
            If Cells(Gyou, Retu) = MyStone Then
'                8方向について処理
                For y = -1 To 1
                    For x = -1 To 1
                        Call LegalSquareColor(Gyou, Retu, y, x)
                    Next x
                Next y
            End If
           
        Next Retu
    Next Gyou
   
End Function
 
'手番の石の色を確認する処理
Function CheckMyStone()
 
    If Cells(2, 11) = "黒の番" Then
        CheckMyStone = "●"
    ElseIf Cells(2, 11) = "白の番" Then
        CheckMyStone = "○"
    End If
   
End Function
 
'着手可能なマスに色をつける処理
'引数：起点となる石の行番号,起点となる石の列番号,上下方向,左右方向
Function LegalSquareColor(Gyou, Retu, Gd, Rd)
   
'    方向が両方0なら終了
    If Gd = 0 And Rd = 0 Then
        Exit Function
    End If
 
    Dim MyStone, OpStone
   
    MyStone = CheckMyStone
    OpStone = CheckOpStone
   
'    一つ移動したマスが「敵の石」なら
    If Cells(Gyou + Gd, Retu + Rd) = OpStone Then
   
'        i個移動したマスを探索
        For i = 2 To 8
'            i個移動したマスが盤面の範囲内に収まっているか=「壁」でないか
            If CheckInBoard(Gyou + Gd * i, Retu + Rd * i) = True Then
           
'                i個移動したマスが「空白」
                If Cells(Gyou + Gd * i, Retu + Rd * i) = "" Then
'                    色をつける
                    Cells(Gyou + Gd * i, Retu + Rd * i).Interior.Color = RGB(219, 190, 107)
'                    関数を終了
                    Exit For
   
'                i個移動したマスが「自分の石」
                ElseIf Cells(Gyou + Gd * i, Retu + Rd * i) = MyStone Then
'                    関数を終了
                    Exit For
                   
                End If
               
'            i個移動したマスが盤面の範囲内に収まっていない=「壁」
            Else
'                関数を終了
                Exit For
   
            End If
           
        Next i
   
    End If
 
End Function

'手番でない石の色を確認する処理
Function CheckOpStone()
 
    If Cells(2, 11) = "黒の番" Then
        CheckOpStone = "○"
    ElseIf Cells(2, 11) = "白の番" Then
        CheckOpStone = "●"
    End If
 
End Function
 
'行番号,列番号が盤面の範囲内に収まっているか確認
Function CheckInBoard(Gyou, Retu)
 
    If Gyou < 2 Or 9 < Gyou Or Retu < 2 Or 9 < Retu Then
        CheckInBoard = False
    Else
        CheckInBoard = True
    End If
   
End Function
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
'    ゲームが終了している場合
    If Cells(2, 11) = "黒の勝ち" Or Cells(2, 11) = "白の勝ち" Or Cells(2, 11) = "引き分け" Then
        Exit Sub
    End If
   
    Dim Gyou, Retu, MyStone
   
'    クリックしたセルの行番号,列番号
    Gyou = Target.Row
    Retu = Target.Column
   
'    着手可能なマスでなければ
    If Cells(Gyou, Retu).Interior.Color <> RGB(219, 190, 107) Then
        Exit Sub
    End If
   
    MyStone = CheckMyStone
   
'    「手番の色の石」を入力
    Cells(Gyou, Retu) = MyStone
   
    For y = -1 To 1
        For x = -1 To 1
            Call TurnOver(Gyou, Retu, y, x)
        Next x
    Next y
   
'    石を数える
    Call CountStone
   
'    勝敗判定/手番変更
    Call CheckEnd
 
End Sub
 
'ひっくり返す処理
Function TurnOver(Gyou, Retu, Gd, Rd)
 
    If Gd = 0 And Rd = 0 Then
        Exit Function
    End If
 
    Dim MyStone, OpStone
 
    MyStone = CheckMyStone
    OpStone = CheckOpStone
   
'    一つ移動したマスが「敵の石なら」
    If Cells(Gyou + Gd, Retu + Rd) = OpStone Then
   
'        i個移動したマスを探索
        For i = 2 To 8
       
'            i個移動したマスが盤面の範囲内に収まっているか = 壁でないか
            If CheckInBoard(Gyou + Gd * i, Retu + Rd * i) Then
               
'                i個移動したマスが「空白」
                If Cells(Gyou + Gd * i, Retu + Rd * i) = "" Then
'                    関数を終了
                    Exit For
           
'                i個移動したマスが「自分の石」
                ElseIf Cells(Gyou + Gd * i, Retu + Rd * i) = MyStone Then
                   
'                    k=1~(i-1)
                    For k = 1 To i - 1
'                        「自分の石」へ変更
                        Cells(Gyou + Gd * k, Retu + Rd * k) = MyStone
                    Next k
                   
'                    関数を終了
                    Exit For
                   
                End If
               
'            i個移動したマスが盤面の範囲内に収まっていない=「壁」
            Else
                Exit For
               
            End If
               
        Next i
       
    End If
   
End Function
 
'石を数える処理
Function CountStone()
 
    Dim BlackCount, WhiteCount, Gyou, Retu
   
'    黒石、白石の数
    BlackCount = 0
    WhiteCount = 0
   
'    盤面の全てのマスを確認して数える
    For Gyou = 2 To 9
        For Retu = 2 To 9
 
            If Cells(Gyou, Retu) = "●" Then
                BlackCount = BlackCount + 1
 
            ElseIf Cells(Gyou, Retu) = "○" Then
                WhiteCount = WhiteCount + 1
 
            End If
 
        Next Retu
    Next Gyou
   
'    個数を入力
    Cells(3, 13) = BlackCount
    Cells(4, 13) = WhiteCount
   
End Function
 
'合法手があるか確認する処理
Function CheckLegalExist()
 
    For Gyou = 2 To 9
        For Retu = 2 To 9
'            背景色がついているマスが存在する場合
            If Cells(Gyou, Retu).Interior.Color = RGB(219, 190, 107) Then
                CheckLegalExist = True
                Exit Function
            End If
           
        Next Retu
    Next Gyou
 
'    背景色がついているマスが存在しない場合
    CheckLegalExist = False
 
End Function
 
'手番を変更する処理
Function ChangeTurn()
 
    If Cells(2, 11) = "黒の番" Then
        Cells(2, 11) = "白の番"
    ElseIf Cells(2, 11) = "白の番" Then
        Cells(2, 11) = "黒の番"
    End If
   
End Function
 
'勝敗判定/手番変更
Function CheckEnd()
   
'    手番の変更
    Call ChangeTurn
   
'    着手可能なマスに色をつける
    Call SearchMyStone
   
'    着手可能なマスがあれば処理終了
    If CheckLegalExist = True Then
        Exit Function
    End If
 
'    手番の変更
    Call ChangeTurn
   
'    着手可能なマスに色をつける
    Call SearchMyStone
   
'    着手可能なマスがあれば処理終了
    If CheckLegalExist = True Then
        Exit Function
    End If
   
'    双方置く場所がないので勝敗の判定
    If Cells(3, 13) < Cells(4, 13) Then
        Cells(2, 11) = "白の勝ち"
    ElseIf Cells(4, 13) < Cells(3, 13) Then
        Cells(2, 11) = "黒の勝ち"
    Else
        Cells(2, 11) = "引き分け"
    End If
   
End Function
0
0
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?