どーも 暇人プログラマーTakeです。

今回も暇すぎて、Excel でトランプを使った「神経衰弱」を作ってみました！！

作成時間はおよそ３時間くらいでした！

わたしは要領が悪いので、作成に結構時間がかかってしまいました。。。

たぶんプログラミングが得意な人はもっと早くできると思います。

この記事では、私が作成した「神経衰弱」の操作方法と作成方法についてご紹介します～！

操作方法

操作方法は下記手順です。

簡単に言うと、設定することして、ボタンを押下すれば、

あとは普通の「神経衰弱」です。

数字の種類（２～１３）

ゲームに使うトランプの数字の種類のことを指します。

たとえば、数字の種類（２～１３）＝ 3 と設定すれば、

トランプの数字（2 ~10、J、Q、K）のうち3種類の数字（たとえば、２、４、Jの3種類）

を使うように設定するということです（この数値はランダムで決定します）。

マークの種類（♥ ♠ ♦ ♣）

ゲームに使うトランプのマークの種類のことです。

これは、「2」か「4」のみ設定できるのですが、

「2」と設定すると、♥ ♠の2種類、「4」と設定すると、♥ ♠ ♦ ♣の4種類が

神経衰弱のゲーム内で使用されるということです。

配置されるカードの枚数について

また配置されるカードの枚数ですが、

数字の種類（２～１３）×記号の種類（♥ ♠ ♦ ♣）の枚数になります。

つまり、最大が１3×4枚＝52 枚となります。

「START」と「FIN」ボタンについて

「START」ボタンを押下することで、ゲームが開始されます。

その際に「ステータス」という箇所が「ゲーム中」に変更されるのが確認できます。

また、トランプが表示されることが確認でき、押下も可能です（画面赤色のセルの箇所）。

「FIN」ボタンを押下することで、ゲームが終了します。

その際に「ステータス」という箇所が「ゲーム終了」に変更されるのが確認できます。

なお「ゲーム終了」状態では、カードを押下しても反応しなくなります。

作成方法

今回は、Excel Vba を用いて作成しました！

作成方法について、全部記述すると長くなるのですがご容赦ください。

※ 専門的な用語もでてきますので、よくわかない方は、ページの一番下のダウンロードボタンから

Excel「神経衰弱」をダウンロードして遊んでみてください！

シート構成

「神経衰弱」はメインシートであるので、実施に神経衰弱を行う用のシートとなります。

実装自体は Excel Vba で行っており、このシートはその実装結果を表示させているだけです。

「トランプマスタ」はトランプに関する情報を登録するシートです。

具体的には、トランプで使用する数字とマークをどういうものを使用するかといったことを登録しています。

この値を参照してトランプとして扱う数字とマークを設定するように Excel Vba 上で動作させています。

作業用シートは実際に神経衰弱のゲームを行っていく上で必要な情報を登録するシートです。

具体的には下記情報を登録しています。

ソースコード

Excel Vba のソースコードについては下記のような構成になっています。

Sheet1(神経衰弱)

ここはシート上のクリックを検知し、その検知した結果、さまざまな処理を行う箇所です。

具体的には、カードを配置する範囲のセルがクリックされている状態で

かつステータスが「ゲーム中」の場合にクリックが検知された場合に様々な処理を行うようにしています。

ソースコード

'シート操作の処理
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim NowCell
    Set NowCell = ActiveCell
    Dim GameStatus
    GameStatus = Worksheets(WORK_SHEET).Range(GAME_STATUS_PLACE).Value

    If GameStatus = MSG_GAME_START _
        And BOARD_Y <= NowCell.Row And NowCell.Row <= BOARD_Y + 8 _
        And BOARD_X <= NowCell.Column And NowCell.Column <= BOARD_X + 20 _
        And NowCell.Value <> "" _
    Then
        
        ' カード押下前の処理
        Call prepareCard(NowCell, NowCell.Address)
        
        ' カード押下時の処理
        Call openCard(NowCell)
        
        ' カード押下後の処理
        Call pushCard(NowCell.Value, NowCell.Address)
        
        'カード終了時のフラグ
        Call finGame
    
    End If
    
End Sub

※ Excel シートのクリック検知について記事を以前記事を作成しましたの、よければ参考にご確認ください。

（わたしは以前これを知らなくてめちゃくちゃ悩んだ覚えがありますが、知っていれば超簡単です！）

【Excel vba】マウスの左クリックのイベントを検知する簡単な方法

2019.2.4

はじめに Excelで将棋のゲームをつくろうとしたときでした。 そういやどうやってマウスクリックを検知すればいいんやろう？ 私は仕事やブログでExcelを取り扱うことが多いですが、セルをクリックしたときにクリックしたことを検知しそこから処理を開始することがわかりませんでした。 いろいろ調べましたが、...

STARTボタン押下処理

ここでは、START ボタンが押下された場合の処理をまとめています。

私が作成したマクロは、STARTボタンを押下することでゲームが開始する仕様になっていますが、

ゲーム開始前の準備をここでは行うということです。

ソースコード

' START ボタン押下処理
Sub main()

    Application.ScreenUpdating = False
    
    Dim numArray
    
    ' メインシート 初期化
    Call setDefaultMainSheet

    ' メインシート 初期化
    Call setDefaultWorkSheet
    
    ' 配置するカードを設定
    numArray = setCard
   
    ' 盤上にカードをセット
    Call setBorad(numArray)

    ' ゲームステータス
    Worksheets(WORK_SHEET).Range(GAME_STATUS_PLACE).Value = MSG_GAME_START

    Application.ScreenUpdating = True

End Sub

' メインシート 初期化
Sub setDefaultMainSheet()

  With Worksheets(MAIN_SHEET)
    
    .Range(Cells(BOARD_Y, X + BOARD_X), Cells(BOARD_Y + 20, X + BOARD_X + 20)).Clear
  
  End With

End Sub


' 作業用シート 初期化
Sub setDefaultWorkSheet()

  With Worksheets(WORK_SHEET)
    
    .Range(FIRST_INFO_PLACE).ClearContents
    .Range(SECOND_INFO_PLACE).ClearContents
    .Range(FIRST_CELL_PLACE).ClearContents
    .Range(SECOND_CELL_PLACE).ClearContents
        
  End With

End Sub

カード押下時の処理

シート上の赤いセルをクリックした場合に実装される処理です。

Sheet1(神経衰弱)で動作を検知し、このソースコードに書かれたプロシージャが実行されるということです。

カード押下前の処理

ここでは、まず一枚目と二枚目のカードが押下されたセルの情報（セルの値とセルの位置）を

「作業用シート」に記述します。

カード押下時の処理

押下されたセルの配色を変更します。

赤色のカードとは、つまり赤色の背景色のセル（セル内の文字も赤色）ということですが、

カードが押下されたということが、カードを開く（表返す）ためにセルの背景色を赤色から白色に変更しています。

また、この際に、♥と♦のマークを赤色、♠と♣を黒色にするように表示します。

（下記はかなり悩んだところなんですが。。。）

Excel Vbaでは、 ♥♠♦♣という文字が読み取れません。

読み取ろうとすると「?」となってしまいます（Excel 2016ではそうなりました。。）。

ですので、今回の対策として、

カード押下後の処理

ここでは、カードが二枚クリックされたかを判定し、

判定した結果、同じ数字であるかそうでないかを比較し、同じならカードを削除します。

判定方法は、「作業用シート」のB2、C2の値が両方空白かどうかで判定します。

両方とも値が含まれていれば、二枚クリックされたということです。

数字の比較については、「作業用シート」のB2、C2の値を比較しますが、

このときカードのマーク無視するようにします（つまり一番最後の文字を無視して数字部分のみ判定します）。

ソースコード

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

' カード押下前の処理
Sub prepareCard(ByVal CardInfo, ByVal CardAddress)

    Dim firstCard
    Dim secondCard
    Dim firstPlace
    Dim secondPlace
        
    firstCard = Worksheets(WORK_SHEET).Range(FIRST_INFO_PLACE).Value
    secondCard = Worksheets(WORK_SHEET).Range(SECOND_INFO_PLACE).Value


    ' 1枚目が押下されたとき
    If firstCard = "" Then
        
        Worksheets(WORK_SHEET).Range(FIRST_INFO_PLACE).Value = CardInfo
        Worksheets(WORK_SHEET).Range(FIRST_CELL_PLACE).Value = CardAddress
        
    ' 2枚目が押下されたとき
    ElseIf secondCard = "" Then
    
        Worksheets(WORK_SHEET).Range(SECOND_INFO_PLACE).Value = CardInfo
        Worksheets(WORK_SHEET).Range(SECOND_CELL_PLACE).Value = CardAddress

    End If

End Sub

' カード押下時の処理
Sub openCard(ByRef CellValue)

    Dim inputValue
    Dim cardValueLast
    
    inputValue = ouputVlookup(CellValue)
    cardValueLast = Right(CellValue, 1)
    
    With CellValue
        .Value = inputValue
        .Borders.LineStyle = xlContinuous
        .Borders.Color = RGB(255, 0, 0)
        .Interior.ColorIndex = CARD_COLOR_WHITE
        
        If cardValueLast = "H" Or cardValueLast = "D" Then
            .Font.ColorIndex = CARD_COLOR_RED
        Else
            .Font.ColorIndex = CARD_COLOR_BLACK
        End If

    End With
              
End Sub

' カード押下後の処理
Sub pushCard(ByVal CardInfo, ByVal CardAddress)

    Dim firstCard
    Dim secondCard
    Dim firstPlace
    Dim secondPlace
        
    firstCard = Worksheets(WORK_SHEET).Range(FIRST_INFO_PLACE).Value
    secondCard = Worksheets(WORK_SHEET).Range(SECOND_INFO_PLACE).Value

    firstPlace = Worksheets(WORK_SHEET).Range(FIRST_CELL_PLACE).Value
    secondPlace = Worksheets(WORK_SHEET).Range(SECOND_CELL_PLACE).Value

    ' 1枚目が押下されたとき
    If secondCard <> "" Then
            
        Sleep WAIT_TIME
        
        ' カードが同じとき
        If Worksheets(WORK_SHEET).Range(JUDGE_PLACE).Value = 1 _
        And firstPlace <> secondPlace _
        Then
            
            Call deleteCard(firstPlace)
            Call deleteCard(secondPlace)

        ' カードが違うとき
        Else

            Call backCard(firstPlace, firstCard)
            Call backCard(secondPlace, secondCard)
                    
        End If
        
        ' 作業用シート 初期化
        Call setDefaultWorkSheet
        
    End If
   
End Sub


' 違うカードをもとに戻す（ひっくり返す）
Private Sub backCard(ByVal CardPlace, ByVal CardValue)

    Application.ScreenUpdating = False
    
    With Worksheets(MAIN_SHEET).Range(CardPlace)
        
        .Value = CardValue
        .ColumnWidth = CARD_HEIGHT
        .RowHeight = CARD_WIDTH
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Font.ColorIndex = CARD_COLOR_RED
        .Interior.ColorIndex = CARD_COLOR_RED
    
    End With
    
    Application.ScreenUpdating = True

End Sub

' 同じカードの場合削除する
Private Sub deleteCard(ByVal CardPlace)

    With Worksheets(MAIN_SHEET).Range(CardPlace)
        
        .ClearContents
        .ColumnWidth = CARD_HEIGHT
        .RowHeight = CARD_WIDTH
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Font.ColorIndex = CARD_COLOR_WHITE
        .Interior.ColorIndex = CARD_COLOR_WHITE
    
    End With

End Sub

ゲーム終了処理

ここでは、ゲーム終了処理に関する処理が含まれます。

ゲームが終了するパターンは主に2通りです。

①のすべてカードがめくられたときの検知方法ですが、

二枚目のカードがクリックされた後に

作業用シートの「残り枚数」と記載のある個所（F2）が０になったときに終了するように処理します。

ソースコード

'ゲーム終了処理
Sub finGame()
    
    Dim finFlag
    
    finFlag = Worksheets(WORK_SHEET).Range(REMAIN_CARD_NUM).Value
    
    If finFlag = 0 Then
    
        MsgBox MSG_FIN_GAME
        
        Worksheets(WORK_SHEET).Range(GAME_STATUS_PLACE).Value = MSG_GAME_END

    End If
    
End Sub

'ゲーム終了押下
Sub pushFinGame()
            
    Worksheets(WORK_SHEET).Range(GAME_STATUS_PLACE).Value = MSG_GAME_END
    
End Sub

定数定義

ここでは、Excel Vba で扱う定数についてまとめて定義しています。

シート名、カードを配置する箇所（盤上という表現で記載）などなどです。

（たぶん、ソースコード見たほうがはやいとおもいます。）

ソースコード

' --- シート情報 ---

Public Const MAIN_SHEET As String = "神経衰弱"
Public Const MASTER_SHEET As String = "トランプマスタ"
Public Const WORK_SHEET As String = "作業用"


' --- 「神経衰弱」シート ---

' データの範囲 盤上の設定
Public Const BOARD_X As Integer = 3
Public Const BOARD_Y As Integer = 6

Public Const SET_NUM_MAIN_RANGE As String = "F3"
Public Const SET_KIGO_MAIN_RANGE As String = "L3"

' カード情報
Public Const CARD_HEIGHT As Integer = 5
Public Const CARD_WIDTH As Integer = 50
Public Const CARD_COLOR_RED As Integer = 3
Public Const CARD_COLOR_WHITE As Integer = 2
Public Const CARD_COLOR_BLACK As Integer = 1

' --- 「トランプマスタ」シート ---

Public Const MASTER_RANGE As String = "A2:B5"


' --- 「作業用」シート ---

' 残りカード枚数
Public Const REMAIN_CARD_NUM As String = "F2"

' 押下カードの情報
Public Const FIRST_INFO_PLACE As String = "B2"
Public Const SECOND_INFO_PLACE As String = "C2"

Public Const FIRST_CELL_PLACE As String = "B3"
Public Const SECOND_CELL_PLACE As String = "C3"

' カードが一致するか
Public Const JUDGE_PLACE As String = "D2"

' カードをもとに戻す時間
Public Const WAIT_TIME As Integer = 1000

' ゲームステータス確認
Public Const GAME_STATUS_PLACE As String = "H2"

' --- その他 ---

' 判定フラグ
Public Const PUSH_FIRST_CARD As Integer = 0
Public Const PUSH_SECOND_CARD_SAME As Integer = 1
Public Const PUSH_SECOND_CARD_DIFF As Integer = 2


' --- メッセージ ----

' ゲームステータス
Public Const MSG_GAME_START As String = "ゲーム中"
Public Const MSG_GAME_END As String = "ゲーム終了"

' ゲーム終了時
Public Const MSG_FIN_GAME As String = "お疲れ様でした！！ゲームを終了します！！"

' VLOOKUPの出力
Function ouputVlookup(ByVal Str)

    ouputVlookup = "=VLOOKUP(""" & Str & """,トランプマスタ!I:K,3,FALSE)"

End Function

配置カードを設定

ここでは「START」ボタン押下時にはじめにカードを配置する処理を記述しています。

大きくは setCard() プロシージャで処理を実装しています。

ちょっとわかりにくかったかもなので、補足します。

はじめに「神経衰弱」シートで「３種類」の数字と「４種類」のマークを使用するとします。

つぎに「３種類」の数字の中からどの数字にするか（1 ~ 10の中で）ランダムに選択します。

たとえば、1、４、９と使うとすると

１、４、９ ×　「４種類」のマーク♥♠♦♣ = 12種類の文字列を作成し、配列に格納します。

そして最終的に配列をランダムにシャッフルし、その配列をシートに出力するということです。

※ ここでは、配列の生成のみで、シートへの出力は別の「盤上へカードを配置」で行います。

ソースコード

' ゲームで使うカードの設定
' 数字 + 記号を文字列を含む配列で返す

Function setCard() As String()

    Dim numArray
    Dim allCardArray
    Dim setCardNumber As Integer
    
    ' 何種類の数字をゲームをするか
    setCardNumber = Worksheets(MAIN_SHEET).Range(SET_NUM_MAIN_RANGE)
    
    ' 上記の種類のランダム数字で決定
    numArray = getCardArray(setCardNumber)
    
    ' 最終的に使うカードの種類を決定
    setCard = decideCardArray(numArray)
    
End Function

' 上記の種類のランダム数字で決定
Private Function getCardArray(ByRef Num As Integer) As String()

    Dim i As Long
    Dim myNum As Long
    Dim numArray() As String
    Dim myFlag(1 To 13) As Boolean

    '乱数系列を初期化
    Randomize
    
    For i = 1 To Num
        Do
            myNum = Int((13 - 1 + 1) * Rnd + 1)
        Loop Until myFlag(myNum) = False
        
        ReDim Preserve numArray(i - 1)
        numArray(i - 1) = myNum
        myFlag(myNum) = True
    Next i

    getCardArray = numArray

End Function


' 最終的に使うカードの種類を決定
Private Function decideCardArray(ByRef numArray) As String()
    
    Dim i As Integer: i = 0
    Dim sumArray() As String
    Dim kigoMaster: kigoMaster = Worksheets(MASTER_SHEET).Range(MASTER_RANGE)
    Dim kigoNum: kigoNum = Worksheets(MAIN_SHEET).Range(SET_KIGO_MAIN_RANGE)

    For Each Var In numArray
        
        ReDim Preserve sumArray(i)
        sumArray(i) = Var & kigoMaster(1, 1)
        i = i + 1
        ReDim Preserve sumArray(i)
        sumArray(i) = Var & kigoMaster(2, 1)
        i = i + 1
        
        If kigoNum = 4 Then
            ReDim Preserve sumArray(i)
            sumArray(i) = Var & kigoMaster(3, 1)
            i = i + 1
            ReDim Preserve sumArray(i)
            sumArray(i) = Var & kigoMaster(4, 1)
            i = i + 1
        End If
    
    Next Var

    decideCardArray = cardShuffle(sumArray)

End Function

' カードをシャッフル
Private Function cardShuffle(ByRef cardArray) As String()

    For i = 0 To UBound(cardArray)
        Randomize
        rn = Int(UBound(cardArray) * Rnd)
        tmp = cardArray(i)
        cardArray(i) = cardArray(rn)
        cardArray(rn) = tmp
    Next
    
    cardShuffle = cardArray

End Function

盤上へカードを配置

「配置カードを設定」で生成した配列をシートに表示させます。

その表示の際に、カードの装飾も行っています。

カードの装飾とはつまりセルの配色を指します（たとえば、セルの値、罫線、背景色など）。

ソースコード

' 盤上へカードを配置
Sub setBorad(ByRef numArray)

    Dim X: X = 0
    Dim Y: Y = 0
    Dim j: j = 0
    
    Dim arraylength: arraylength = UBound(numArray) + 1
    
    Do
        ' カードの装飾
        Call paintCard(numArray(j), X + BOARD_X, Y + BOARD_Y)
        
        If X >= 20 Then
            X = 0
            Y = Y + 2
        Else
            X = X + 2
        End If
        
        arraylength = arraylength - 1
        j = j + 1
    
    Loop Until arraylength = 0

End Sub

' カードの装飾
Private Sub paintCard(ByVal CardValue, ByVal X, ByVal Y)
 
    With Worksheets(MAIN_SHEET).Cells(Y, X)
        
        .Value = CardValue
        .ColumnWidth = CARD_HEIGHT
        .RowHeight = CARD_WIDTH
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Orientation = xlVertical
        .Font.Bold = True
        .Font.ColorIndex = CARD_COLOR_RED
        .Interior.ColorIndex = CARD_COLOR_RED

    End With

End Sub

まとめ

いかがでしょうか？

Excel Vba があれば簡単に作れますでのよければぜひ作ってみてください！

※ 作成した Excel 「神経衰弱」は下記からダウンロードできます。よければぜひ遊んでみてください！

スーパー暇人プログラマー の Take です。

半年ぶり？ぐらいに Excel でゲームをつくりました。

それは、、、

小学校とかで友人とよくやった「あの〇と×を書くだけの究極の頭脳戦」である「まるばつゲーム」です！！！！

この記事をご覧の方の中には、懐かしすぎて涙が止まらない人もたくさんいるのではないでしょうか？

この記事では、「あの〇と×を書くだけの究極の頭脳戦」である「まるばつゲーム」の遊び方と作成方法をご紹介します！！

※ もし「まるばつゲーム」が好きすぎて仕方ない人は、ぜひ下記ボタンからダウンロードしてやってみてください！

遊び方

まず「ゲーム開始」ボタンを押下します。

その後、下記画面の赤枠にクリックすると、自動で「〇」か「×」が入力されます。

※ 先行は「〇」後攻は「×」が入力されます。

あとは、同じ記号（「〇」か「×」）が三つそろえば勝ちという

シンプル中のシンプルなまるばつゲームするだけです。

勝敗が付いた時点でゲームが終了し、メッセージが表示されます。

※ 中断したい場合は「ゲーム終了」を押下してください。

「まるばつゲーム」の作り方

ここからプログラムの専門用語がでてきますので、よくわからない人も適当に眺めてください。

まず、Excel Vba という、Excel のプログラミング言語で作成します。

定数定義

シート情報、まるばつゲームのボード情報、その他メッセージ等をここで一括に登録しちゃいます。

ソースコード

' 定数定義

' シート名
Public Const MARUBATSU_SHEET As String = "marubatsu"

'メッセージの表示位置
Public Const X_MESSAGE As Integer = 14
Public Const Y_MESSAGE As Integer = 3


' ボードのセル番号
Public Const BOARD_X As Integer = 8
Public Const BOARD_Y As Integer = 4
Public Const BOARD_MAX As Integer = 2

' その他定数
Public Const MARU As String = "〇"
Public Const BATSU As String = "×"
Public Const START_MESSAGE As String = "ゲーム開始"
Public Const END_MESSAGE As String = "ゲーム終了"
Public Const WIN_MESSAGE As String = "の勝ち！！！"
Public Const DRAWN_MESSAGE As String = "引き分け！！！"

ボタンが押されたときに処理するマクロ

Excel 上のシートにある「ゲーム開始」「ゲーム終了」ボタンが押されたときに処理するマクロの定義です。

ボタンごとにそれぞれ下記のように動作します。

また、上記画面の「ゲーム開始」というメッセージの下に「0」という文字がありますが、

これは盤上の「〇と×」の数を示します。

※ 上記画面では、「〇と×」が「０」個のため、「０」と表示されています。

ソースコード

'まるばつゲーム 開始
Sub startGame()
    
    Call defaultSet

    setMsg (START_MESSAGE)

End Sub

'まるばつゲーム 終了
Sub endGame()
    
    setMsg (END_MESSAGE)

End Sub


' 初期設定
Private Sub defaultSet()
    
    Range(Cells(BOARD_Y, BOARD_X), Cells(BOARD_Y + 2, BOARD_X + 2)).ClearContents
    
End Sub


' メッセージの設定
Private Sub setMsg(Msg As String)

    Worksheets(MARUBATSU_SHEET).Cells(Y_MESSAGE, X_MESSAGE).Value = Msg
    Worksheets(MARUBATSU_SHEET).Cells(Y_MESSAGE + 1, X_MESSAGE).Value = 0
    
End Sub

マウスクリック等のシートの操作

下記ソースコードで、ごちゃごちゃ書いていますが、処理はシンプルです。

※ もしシート上のクリックをどうやって検知しているかわからない人は下記リンクをどうぞ！

【Excel vba】マウスの左クリックのイベントを検知する簡単な方法

2019.2.4

はじめに Excelで将棋のゲームをつくろうとしたときでした。 そういやどうやってマウスクリックを検知すればいいんやろう？ 私は仕事やブログでExcelを取り扱うことが多いですが、セルをクリックしたときにクリックしたことを検知しそこから処理を開始することがわかりませんでした。 いろいろ調べましたが、...

ソースコード

' シートの操作部分
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
    Dim NowCell
    Set NowCell = ActiveCell
    
    Dim Msg As String: Msg = Worksheets(MARUBATSU_SHEET).Cells(Y_MESSAGE, X_MESSAGE).Value
    
    If Msg = START_MESSAGE _
    And BOARD_Y <= NowCell.Row _
    And NowCell.Row <= BOARD_Y + BOARD_MAX _
    And BOARD_X <= NowCell.Column _
    And NowCell.Column <= BOARD_X + BOARD_MAX _
    Then
    
        With Worksheets(MARUBATSU_SHEET).Cells(NowCell.Row, NowCell.Column)
            If getCount Mod 2 = 0 Then
              .Value = MARU
            Else
              .Value = BATSU
            End If
        End With
        
        ' 〇×の数をカウント
        Call plusCount
        
        ' 勝敗チェック
        If checkGame(getCount) = True Then
        
            Dim Winner
            
            If getCount Mod 2 = 1 Then
              Winner = MARU
            Else
              Winner = BATSU
            End If
            
            MsgBox Winner & WIN_MESSAGE
            Call endGame
        End If
        
        If getCount = 9 And checkGame(getCount) = False Then
            
            MsgBox DRAWN_MESSAGE
        
        End If
    
    End If
    
End Sub

' カウント設定
Private Sub plusCount()

    Worksheets(MARUBATSU_SHEET).Cells(Y_MESSAGE + 1, X_MESSAGE).Value _
        = Worksheets(MARUBATSU_SHEET).Cells(Y_MESSAGE + 1, X_MESSAGE).Value + 1
    
End Sub

' カウントを取得
Function getCount() As String

    getCount = Worksheets(MARUBATSU_SHEET).Cells(Y_MESSAGE + 1, X_MESSAGE).Value

End Function

' 値を取得
Function getValue(ByRef X, ByRef Y) As String

    getValue = Worksheets(MARUBATSU_SHEET).Cells(Y, X).Value

End Function

' 勝敗チェック
Function checkGame(num As String) As Boolean

    checkGame = False
    
    For Y = BOARD_Y To BOARD_Y + BOARD_MAX

        For X = BOARD_X To BOARD_X + BOARD_MAX
            
            If getValue(X, Y) = MARU _
            Or getValue(X, Y) = BATSU _
            Then
            
                Dim firstValue: firstValue = getValue(X, Y)
                
                If isSameValue(firstValue, X, X, Y + 1, Y + BOARD_MAX) = True _
                Or isSameValue(firstValue, X + 1, X + BOARD_MAX, Y, Y) = True _
                Or isSameValue(firstValue, X + 1, X + BOARD_MAX, Y + 1, Y + BOARD_MAX) = True _
                Or isSameValue(firstValue, X - 1, X - BOARD_MAX, Y + 1, Y + BOARD_MAX) = True _
                Then
                
                    checkGame = True
                    Exit For
                End If

            End If
                                     
            Next X
            
        If checkGame = True Then
            
            Exit For
        
        End If
    
    Next Y


End Function

' 指定の座標が同じ値か確認
Function isSameValue(ByRef Value, ByRef X1, _
                    ByRef X2, ByRef Y1, ByRef Y2) As Boolean

    If getValue(X1, Y1) = Value And getValue(X2, Y2) = Value _
    Then
    
        isSameValue = True
    End If

End Function

最後に

いかがでしょうか？

私はこの「まるばつゲーム」をつくるのに一時間くらいかかりました。

たぶん、できる人はもっと早くできると思います。

もし「〇と×の究極の頭脳戦」である「まるばつゲーム」を Excel でやりたくて仕方ない方がいましたら、

ぜひ下記ボタンからダウンロードしてやってみてください！

前からつくってみたいなあと思っていたゲームの一つで、これもなかなか時間がかかりました。

仕事終わってからだらだら作っていたら一週間くらいかかりました（工数はだいたい１人日～２人日くらい）。

ですが、思ったより簡単に作れました。エクセルで過去にオセロや将棋などつくりましたが、

毎回思うことがゲーム作りに必要なものは根気と気合です。

この記事では、作成したテトリスについて、その操作方法と作成方法についてご紹介します。

※ 作成方法したエクセルのテトリスについては下記からダウンロード可能ですので、ぜひ遊んでみてください。

操作方法

作成したテトリスの操作方法について説明します。

ゲームの開始と終了

テトリスを開始するときは「START」ボタンをクリックしますが、ゲームを終了する場合はキーボードの「Home」キーを押下します。

キーボード操作

後は、いつものテトリスです。ブロックを一行そろえて消すだけです。

またテトリスには、一行ずつ消すよりもまとめて消したほうがお得というルールがありますね。今回それを下記式で表しています。

テトリスを作った割にテトリスのポイントのつけ方がよくわからなかったので、こんな感じで付けました。

Score とは点数のことで、「Score = Score + ~ 」とは、もともとの Score の値にどんどん足していきますよということです。

例えば削除した行が１行なら Score = 400点、2行なら700点つきます（答えを知っている人は教えてほしいです）。

終了条件

前述しましたがゲームを終了する場合はキーボードの「Home」キーを押下しますが、それ以外にもテトリスが続行できない場合も終了するようにしています。

要はブロックが天井を突き抜けた状態です。このときは強制的にテトリスが終了します。

作成方法

Excel vba で作成しています。要はプログラミングして作成しました。

実際のテトリスの作成手順は下記の５つになります。この５つができればテトリスは作れます。

これだけみれば、「案外簡単そうだなあ」と思われる人もいるかもしれませんが、案外めんどくさいです。

特にめんどくさいのが、ブロックの移動、回転の処理です。では順をおって説明します。

メイン関数

作成したテトリスのメイン関数です。

処理概要を説明しますと、まず定数、変数の定義とレイアウト作成などの下準備を行います。

その後 Do While True ~ をつかって無限ループさせ、ブロックを落とすようにします。

その無限ループの処理の中で下記の処理を行います。

これだけです。天井という言い方が正しいかはわかりませんが、

ブロックが指定したセルの行よりあれば終了するようにしています（先ほど貼ったやつです）。

ソースコード

'メイン
Sub Tetris()
    
    Dim x As Integer
    Dim y As Integer
    Dim n As Integer
    Dim i As Integer
    Dim Block As Integer: Block = 0
    Dim Next_Block As Integer: Next_Block = 0
    
    ' 初期化
    Call setting(x, y)
    
    Do While True
        x = START_X
        y = START_Y
        ROTATE_NUM = 0
        
        Call setBlock(Block, Next_Block)
    
        For y = START_Y To BOTTOM_Y
            For n = 1 To 3
                Call setEvent(x, y, Block)
                Application.Wait [Now() +  "00:00:00.10"]
            Next n
            
            ' ブロックを移動できない状態ならブロックを削除
            If DropBlock(x, y, Block) = False Then
                Call checkRowBlock
                Exit For
            End If
        Next y
        Call checkgame
    Loop
    
End Sub

次にメイン関数の処理をプロシージャにわけて説明します。

下準備（定数と変数の定義 & レイアウトの作成）

定数と変数の定義

まず初めに定数と変数の定義します。

記事作成での都合上、最初に定数と変数の定義を最初にきていますが、プログラミングをしている段階では、必要なたびにどんどん定義しています（当たり前ですが、）。

定数については、レイアウトの位置情報（何行何列目のセルに描くか）とブロックの色について定義づけしています（固定なので）。

また、変数については、ブロックの先頭セルと、テトリスのスコア、ブロックの回転数について定義しています。これらは後で説明しますのでいまは適当に流していただいて問題ありません。

ソースコード

'シート名
Public Const TETRIS_SHEET As String = "Tetris"

'テトリス位置
Public Const BOTTOM_Y As Integer = 27
Public Const BOTTOM_X_LEFT As Integer = 3
Public Const BOTTOM_X_RIGHT As Integer = 15
Public Const START_X As Integer = 8
Public Const START_Y As Integer = 4

'ブロックの先頭位置
Public TOP_X_L As Integer
Public TOP_X_R As Integer
Public TOP_Y As Integer

'ブロックの先頭位置
Public Const NEXT_START_X As Integer = 23
Public Const NEXT_START_Y As Integer = 7

' スコア
Public Const SCORE_POSITION_X As Integer = 24
Public Const SCORE_POSITION_Y As Integer = 12
Public Score As Integer

' 回転数
Public ROTATE_NUM As Integer

'色の定義 0 → 白 | 1 → 黒
Public Const NO_COLOR As Integer = 0
Public Const BLOCK1_COLOR As Integer = 3
Public Const BLOCK2_COLOR As Integer = 8
Public Const BLOCK3_COLOR As Integer = 5
Public Const BLOCK4_COLOR As Integer = 50
Public Const BLOCK5_COLOR As Integer = 46
Public Const BLOCK6_COLOR As Integer = 29
Public Const BLOCK7_COLOR As Integer = 27

テトリスのレイアウト

テトリスの枠のレイアウトを vba で書くようにします。

これはもし間違えてシート上のセルを消してしまった場合も問題ないようにするためです。

作成するレイアウトは、下記画像の青矢印の箇所（テトリスの周りのブロックと、次のテトリスを表示させる黒枠の箇所）です。

また、もともとブロックが描いてある場合もいったん消してきれいにするようにしています。

下記はソースコードですが、setting プロシージャがメイン関数で、その中に ①テトリスの周りのブロックと、②次のテトリスを表示させる黒枠の箇所のレイアウトの設定を行っています。

ソースコード

Option Explicit

' 初期化
Sub setting(ByRef x As Integer, ByRef y As Integer)

    x = START_X
    y = START_Y
    Score = 0
    ROTATE_NUM = 0
    
    Application.ScreenUpdating = False
    
    Call settingTetris

    Call settingNextBlock
    
    Worksheets(TETRIS_SHEET).Cells(SCORE_POSITION_Y, SCORE_POSITION_X).Value = Score

End Sub

Private Sub settingTetris()

    Application.ScreenUpdating = False
    
    With Worksheets(TETRIS_SHEET).Range(Cells(START_Y, BOTTOM_X_LEFT), Cells(BOTTOM_Y, BOTTOM_X_LEFT))
        .Interior.color = RGB(192, 192, 192)
        .Borders.LineStyle = xlContinuous
    End With
    
    With Worksheets(TETRIS_SHEET).Range(Cells(START_Y, BOTTOM_X_RIGHT), Cells(BOTTOM_Y, BOTTOM_X_RIGHT))
        .Interior.color = RGB(192, 192, 192)
        .Borders.LineStyle = xlContinuous
    End With

    With Worksheets(TETRIS_SHEET).Range(Cells(BOTTOM_Y, BOTTOM_X_LEFT), Cells(BOTTOM_Y, BOTTOM_X_RIGHT))
        .Interior.color = RGB(192, 192, 192)
        .Borders.LineStyle = xlContinuous
    End With

    Worksheets(TETRIS_SHEET).Range(Cells(1, BOTTOM_X_LEFT + 1), Cells(BOTTOM_Y - 1, BOTTOM_X_RIGHT - 1)).ClearFormats
    
    Application.ScreenUpdating = True

End Sub

Sub settingNextBlock()

    Application.ScreenUpdating = False
    
    Worksheets(TETRIS_SHEET).Range(Cells(START_Y + 1, NEXT_START_X - 1), Cells(START_Y + 4, NEXT_START_X + 3)).ClearFormats
    
    Application.ScreenUpdating = True
    
End Sub

ブロックを描く

テトリスのブロックは下記の７種類あるそうです。なので、これを描くようにします。

今回これらのブロックに名前をつけています。左から１、２ .... ７という数値をつけそれを Block という変数にもたせるようにしています。

ブロックの描き方についてはただセルに色と枠線をつけるだけです。

また、セルに入れる処理を毎回書くのが面倒だったので、paintColor プロシージャにまとめ、座標情報（何行何列目に入力するか）のみで描けるようにしてあります。

ソースコード

Option Explicit

' ランダムにブロックを取得
Sub getRandBlock(ByVal x As Integer, ByVal y As Integer, ByRef Block As Integer)
    
    Select Case Block
        Case 1
            Call makeBlock1(x, y)
        Case 2
            Call makeBlock2(x, y)
        Case 3
            Call makeBlock3(x, y)
        Case 4
            Call makeBlock4(x, y)
        Case 5
            Call makeBlock5(x, y)
        Case 6
            Call makeBlock6(x, y)
        Case 7
            Call makeBlock7(x, y)
    End Select

    Call setTopPlace(x, y, Block)

End Sub

' 正方形　ブロック作成
Private Sub makeBlock1(ByVal x As Integer, ByVal y As Integer)
    
    Const color As Integer = BLOCK1_COLOR
    
    Call paintColor(color, x + 1, y)
    Call paintColor(color, x + 2, y)
    Call paintColor(color, x + 1, y - 1)
    Call paintColor(color, x + 2, y - 1)
    
End Sub

' 長方形　ブロック作成
Private Sub makeBlock2(ByVal x As Integer, ByVal y As Integer)
    
    Const color As Integer = BLOCK2_COLOR
    
    If ROTATE_NUM = 0 Then
        Call paintColor(color, x + 2, y)
        Call paintColor(color, x + 2, y - 1)
        Call paintColor(color, x + 2, y - 2)
        Call paintColor(color, x + 2, y - 3)
    Else
        Call paintColor(color, x, y - 2)
        Call paintColor(color, x + 1, y - 2)
        Call paintColor(color, x + 2, y - 2)
        Call paintColor(color, x + 3, y - 2)
    End If
    
End Sub

' L字　ブロック作成
Private Sub makeBlock3(ByVal x As Integer, ByVal y As Integer)
    
    Const color As Integer = BLOCK3_COLOR
    
    If ROTATE_NUM = 1 Then
        Call paintColor(color, x, y)
        Call paintColor(color, x, y - 1)
        Call paintColor(color, x, y - 2)
        Call paintColor(color, x + 1, y - 2)
    ElseIf ROTATE_NUM = 2 Then
        Call paintColor(color, x, y - 1)
        Call paintColor(color, x + 1, y - 1)
        Call paintColor(color, x + 2, y - 1)
        Call paintColor(color, x + 2, y)
    ElseIf ROTATE_NUM = 3 Then
        Call paintColor(color, x, y)
        Call paintColor(color, x + 1, y)
        Call paintColor(color, x + 1, y - 1)
        Call paintColor(color, x + 1, y - 2)
    Else
        Call paintColor(color, x, y)
        Call paintColor(color, x + 1, y)
        Call paintColor(color, x + 2, y)
        Call paintColor(color, x, y - 1)
    End If
    
End Sub

' 逆L字　ブロック作成
Private Sub makeBlock4(ByVal x As Integer, ByVal y As Integer)
    
    Const color As Integer = BLOCK4_COLOR
    
    If ROTATE_NUM = 1 Then
        Call paintColor(color, x, y)
        Call paintColor(color, x, y - 1)
        Call paintColor(color, x, y - 2)
        Call paintColor(color, x + 1, y)
    ElseIf ROTATE_NUM = 2 Then
        Call paintColor(color, x, y)
        Call paintColor(color, x, y - 1)
        Call paintColor(color, x + 1, y - 1)
        Call paintColor(color, x + 2, y - 1)
    ElseIf ROTATE_NUM = 3 Then
        Call paintColor(color, x, y - 2)
        Call paintColor(color, x + 1, y)
        Call paintColor(color, x + 1, y - 1)
        Call paintColor(color, x + 1, y - 2)
    Else
        Call paintColor(color, x, y)
        Call paintColor(color, x + 1, y)
        Call paintColor(color, x + 2, y)
        Call paintColor(color, x + 2, y - 1)
    End If
    
End Sub

' 山　ブロック作成
Private Sub makeBlock5(ByVal x As Integer, ByVal y As Integer)
    
    Const color As Integer = BLOCK5_COLOR
    
    If ROTATE_NUM = 1 Then
        Call paintColor(color, x + 1, y)
        Call paintColor(color, x + 1, y - 1)
        Call paintColor(color, x + 1, y - 2)
        Call paintColor(color, x + 2, y - 1)
    ElseIf ROTATE_NUM = 2 Then
        Call paintColor(color, x, y - 1)
        Call paintColor(color, x + 1, y - 1)
        Call paintColor(color, x + 2, y - 1)
        Call paintColor(color, x + 1, y)
    ElseIf ROTATE_NUM = 3 Then
        Call paintColor(color, x, y - 1)
        Call paintColor(color, x + 1, y)
        Call paintColor(color, x + 1, y - 1)
        Call paintColor(color, x + 1, y - 2)
    Else
        Call paintColor(color, x, y - 1)
        Call paintColor(color, x + 1, y - 1)
        Call paintColor(color, x + 1, y - 2)
        Call paintColor(color, x + 2, y - 1)
    End If
    
End Sub

' Z字　ブロック作成
Private Sub makeBlock6(ByVal x As Integer, ByVal y As Integer)
    
    Const color As Integer = BLOCK6_COLOR
    
    If ROTATE_NUM = 1 Then
        Call paintColor(color, x, y)
        Call paintColor(color, x, y - 1)
        Call paintColor(color, x + 1, y - 1)
        Call paintColor(color, x + 1, y - 2)
    Else
        Call paintColor(color, x, y - 1)
        Call paintColor(color, x + 1, y)
        Call paintColor(color, x + 1, y - 1)
        Call paintColor(color, x + 2, y)
    End If
    
End Sub

' 逆Z字　ブロック作成
Private Sub makeBlock7(ByVal x As Integer, ByVal y As Integer)
    
    Const color As Integer = BLOCK7_COLOR
    
    If ROTATE_NUM = 1 Then
        Call paintColor(color, x, y - 1)
        Call paintColor(color, x, y - 2)
        Call paintColor(color, x + 1, y)
        Call paintColor(color, x + 1, y - 1)
    Else
        Call paintColor(color, x, y)
        Call paintColor(color, x + 1, y)
        Call paintColor(color, x + 1, y - 1)
        Call paintColor(color, x + 2, y - 1)
    End If
    
End Sub

' セルの色つける
Private Sub paintColor(ByVal color As Integer, ByVal x As Integer, ByVal y As Integer)

    Application.ScreenUpdating = False
    
    With Worksheets(TETRIS_SHEET).Cells(y, x)
        .Borders.LineStyle = xlContinuous
        .Interior.ColorIndex = color
    End With
    Application.ScreenUpdating = True
    
End Sub

具体的には 1 ~ 7 のうちのランダムな数値を取得し、取得した値からブロックを生成するようにします。

例えば 3 という数値が取得したらブロック３を出力するようにします。

ソースコード

' 落とすブロックのセット
Private Sub setBlock(ByRef Block As Integer, ByRef Next_Block As Integer)
        
    Randomize
    
    Call settingNextBlock

    If Block = 0 Then
        Block = Int(7 * Rnd + 1)
    Else
        Block = Next_Block
    End If

    Next_Block = Int(7 * Rnd + 1)
    
    Select Case Next_Block
        Case 1
            Call getRandBlock(NEXT_START_X - 1, NEXT_START_Y, Next_Block)
        Case 2
            Call getRandBlock(NEXT_START_X - 1, NEXT_START_Y + 1, Next_Block)
        Case 5
            Call getRandBlock(NEXT_START_X, NEXT_START_Y + 1, Next_Block)
        Case Else
            Call getRandBlock(NEXT_START_X, NEXT_START_Y, Next_Block)
    End Select
    
    Call getRandBlock(START_X, START_Y, Block)
    
End Sub

またブロックの削除処理もつくっています。

これはブロックを移動させるときに必要な処理です（後で説明します）。

ブロックの削除の仕方ですが、簡単に指定した行と列の書式を削除しているだけです。

ソースコード

Option Explicit

' ランダムにブロックを取得
Sub deleteRandBlock(ByVal x As Integer, ByVal y As Integer, ByRef Block As Integer)
    
    Select Case Block
        Case 1
            Call deleteBlock1(x, y)
        Case 2
            Call deleteBlock2(x, y)
        Case 3
            Call deleteBlock3(x, y)
        Case 4
            Call deleteBlock4(x, y)
        Case 5
            Call deleteBlock5(x, y)
        Case 6
            Call deleteBlock6(x, y)
        Case 7
            Call deleteBlock7(x, y)
    End Select

End Sub

' 正方形　ブロック削除
Private Sub deleteBlock1(ByVal x As Integer, ByVal y As Integer)
    
    Const color As Integer = 3
    
    Call deleteFormat(x + 1, y)
    Call deleteFormat(x + 2, y)
    Call deleteFormat(x + 1, y - 1)
    Call deleteFormat(x + 2, y - 1)
    
End Sub

' 長方形　ブロック削除
Private Sub deleteBlock2(ByVal x As Integer, ByVal y As Integer)
    
    Const color As Integer = 8
    
    If ROTATE_NUM = 0 Then
        Call deleteFormat(x + 2, y)
        Call deleteFormat(x + 2, y - 1)
        Call deleteFormat(x + 2, y - 2)
        Call deleteFormat(x + 2, y - 3)
    Else
        Call deleteFormat(x, y - 2)
        Call deleteFormat(x + 1, y - 2)
        Call deleteFormat(x + 2, y - 2)
        Call deleteFormat(x + 3, y - 2)
    End If
    
End Sub

' L字　ブロック削除
Private Sub deleteBlock3(ByVal x As Integer, ByVal y As Integer)
    
    Const color As Integer = 5
    
    If ROTATE_NUM = 1 Then
        Call deleteFormat(x, y)
        Call deleteFormat(x, y - 1)
        Call deleteFormat(x, y - 2)
        Call deleteFormat(x + 1, y - 2)
    ElseIf ROTATE_NUM = 2 Then
        Call deleteFormat(x, y - 1)
        Call deleteFormat(x + 1, y - 1)
        Call deleteFormat(x + 2, y - 1)
        Call deleteFormat(x + 2, y)
    ElseIf ROTATE_NUM = 3 Then
        Call deleteFormat(x, y)
        Call deleteFormat(x + 1, y)
        Call deleteFormat(x + 1, y - 1)
        Call deleteFormat(x + 1, y - 2)
    Else
        Call deleteFormat(x, y)
        Call deleteFormat(x + 1, y)
        Call deleteFormat(x + 2, y)
        Call deleteFormat(x, y - 1)
    End If
    
End Sub

' 逆L字　ブロック削除
Private Sub deleteBlock4(ByVal x As Integer, ByVal y As Integer)
    
    Const color As Integer = 50
    
    If ROTATE_NUM = 1 Then
        Call deleteFormat(x, y)
        Call deleteFormat(x, y - 1)
        Call deleteFormat(x, y - 2)
        Call deleteFormat(x + 1, y)
    ElseIf ROTATE_NUM = 2 Then
        Call deleteFormat(x, y)
        Call deleteFormat(x, y - 1)
        Call deleteFormat(x + 1, y - 1)
        Call deleteFormat(x + 2, y - 1)
    ElseIf ROTATE_NUM = 3 Then
        Call deleteFormat(x, y - 2)
        Call deleteFormat(x + 1, y)
        Call deleteFormat(x + 1, y - 1)
        Call deleteFormat(x + 1, y - 2)
    Else
        Call deleteFormat(x, y)
        Call deleteFormat(x + 1, y)
        Call deleteFormat(x + 2, y)
        Call deleteFormat(x + 2, y - 1)
    End If
    
End Sub

' 山　ブロック削除
Private Sub deleteBlock5(ByVal x As Integer, ByVal y As Integer)
    
    Const color As Integer = 46
    
    If ROTATE_NUM = 1 Then
        Call deleteFormat(x + 1, y)
        Call deleteFormat(x + 1, y - 1)
        Call deleteFormat(x + 1, y - 2)
        Call deleteFormat(x + 2, y - 1)
    ElseIf ROTATE_NUM = 2 Then
        Call deleteFormat(x, y - 1)
        Call deleteFormat(x + 1, y - 1)
        Call deleteFormat(x + 2, y - 1)
        Call deleteFormat(x + 1, y)
    ElseIf ROTATE_NUM = 3 Then
        Call deleteFormat(x, y - 1)
        Call deleteFormat(x + 1, y)
        Call deleteFormat(x + 1, y - 1)
        Call deleteFormat(x + 1, y - 2)
    Else
        Call deleteFormat(x, y - 1)
        Call deleteFormat(x + 1, y - 1)
        Call deleteFormat(x + 1, y - 2)
        Call deleteFormat(x + 2, y - 1)
    End If
    
End Sub

' Z字　ブロック削除
Private Sub deleteBlock6(ByVal x As Integer, ByVal y As Integer)
    
    Const color As Integer = 29
    
    If ROTATE_NUM = 1 Then
        Call deleteFormat(x, y)
        Call deleteFormat(x, y - 1)
        Call deleteFormat(x + 1, y - 1)
        Call deleteFormat(x + 1, y - 2)
    Else
        Call deleteFormat(x, y - 1)
        Call deleteFormat(x + 1, y)
        Call deleteFormat(x + 1, y - 1)
        Call deleteFormat(x + 2, y)
    End If
    
End Sub

' 逆Z字　ブロック削除
Private Sub deleteBlock7(ByVal x As Integer, ByVal y As Integer)
    
    Const color As Integer = 27
    
    If ROTATE_NUM = 1 Then
        Call deleteFormat(x, y - 1)
        Call deleteFormat(x, y - 2)
        Call deleteFormat(x + 1, y)
        Call deleteFormat(x + 1, y - 1)
    Else
        Call deleteFormat(x, y)
        Call deleteFormat(x + 1, y)
        Call deleteFormat(x + 1, y - 1)
        Call deleteFormat(x + 2, y - 1)
    End If
    
End Sub

' セルの書式の削除
Private Sub deleteFormat(ByVal x As Integer, ByVal y As Integer)
    
    Application.ScreenUpdating = False
    With Worksheets(TETRIS_SHEET).Cells(y, x)
        .ClearFormats
    End With
    Application.ScreenUpdating = True
End Sub

ブロックの移動、回転

ブロックの移動は「←」「↑」「↓」「→」のキーボード入力で行っています。

「←」「↑」「↓」「→」のキーボード入力のイベントを検知したときに、下記プロシージャが呼び出されるようにしてあります。

ブロックの移動についてですが、移動前のブロックの書式を削除→次のブロックに色をつけるというふたつの処理を行っています。

前章「ブロックを描く」で説明しました、「ブロックを描く」処理と「ブロックを削除」処理の二つを呼び出して処理させています。

またブロックを移動させるときの注意点は移動範囲です。

当然ですがブロックが壁を貫いたり、底を突き抜けて動いていたらテトリスになりません。

ですので今回はブロックごとに先頭セルをもたせてあり、先頭セルの次の行ももしくは列のセルの色が白色（背景色）でならブロックが移動できるようにしています。

ソースコード

Option Explicit

#If VBA7 Then
'32bit PC
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal ms As Long)
Private Declare Function GetAsyncKeyState Lib "user32.dll" (ByVal vKey As Long) As Long
#Else
'64bit PC
Private Declare PtrSafe Sub Sleep Lib "kernel32.dll" (ByVal ms As LongPtr)
Private Declare PtrSafe Function GetAsyncKeyState Lib "user32.dll" (ByVal vKey As LongPtr) As Long
#End If

' キーボードイベント検知
Sub setEvent(ByRef x As Integer, ByRef y As Integer, ByRef Block As Integer)
    ' 左矢印
    If GetAsyncKeyState(vbKeyLeft) <> 0 Then
        Call moveLeft(x, y, Block)
    End If
    ' 右矢印
    If GetAsyncKeyState(vbKeyRight) <> 0 Then
        Call moveRight(x, y, Block)
    End If
    ' 下矢印
    If GetAsyncKeyState(vbKeyDown) <> 0 Then
        Call moveDown(x, y, Block)
    End If
    ' Ctrl 回転
    If GetAsyncKeyState(vbKeyControl) <> 0 Then
        Call rotateBlock(x, y, Block)
    End If
    ' Homeボタン 終了
    If GetAsyncKeyState(vbKeyHome) <> 0 Then
        MsgBox "Game Fin!" & Chr(13) & "Score : " & Score
        End
    End If
End Sub

' 右に移動
Private Sub moveRight(ByRef x As Integer, ByRef y As Integer, ByRef Block As Integer)
    
    If TOP_X_R <= BOTTOM_X_RIGHT And checkColor_Right(TOP_X_R, y, Block) = True Then
        Call deleteRandBlock(x, y, Block)
        x = x + 1
        Call getRandBlock(x, y, Block)
    End If
End Sub

' 左に移動
Private Sub moveLeft(ByRef x As Integer, ByRef y As Integer, ByRef Block As Integer)
    
    If TOP_X_L > BOTTOM_X_LEFT And checkColor_Left(TOP_X_L, y, Block) = True Then
        Call deleteRandBlock(x, y, Block)
        x = x - 1
        Call getRandBlock(x, y, Block)
    End If
End Sub

' 下に移動
Private Sub moveDown(ByRef x As Integer, ByRef y As Integer, ByRef Block As Integer)
    
    If TOP_Y < BOTTOM_Y And checkColor_Down(x, TOP_Y, Block) = True Then
        Call deleteRandBlock(x, y, Block)
        y = y + 1
        Call getRandBlock(x, y, Block)
    End If
End Sub

' 自然にブロックが落ちる動き
Function DropBlock(ByRef x As Integer, ByRef y As Integer, ByRef Block As Integer) As Boolean

    If TOP_Y < BOTTOM_Y And checkColor_Down(TOP_X_R, TOP_Y, Block) = True Then
        Call deleteRandBlock(x, y, Block)
        Call getRandBlock(x, y + 1, Block)
        DropBlock = True
    Else
        DropBlock = False
    End If

    
End Function

' 隣の色の確認 置ける箇所ならTrue 左方向
Function checkColor_Left(ByVal x As Integer, ByVal y As Integer, ByRef Block As Integer) As Boolean

    checkColor_Left = False
    
    Select Case Block
        Case 1
            If checkNoColor(TOP_X_L - 1, TOP_Y) = True _
            And checkNoColor(TOP_X_L - 1, TOP_Y - 1) = True _
            Then
                checkColor_Left = True
            End If
        Case 2
            Select Case ROTATE_NUM
                Case 0
                    If checkNoColor(TOP_X_L - 1, TOP_Y) = True _
                    And checkNoColor(TOP_X_L - 1, TOP_Y - 1) = True _
                    And checkNoColor(TOP_X_L - 1, TOP_Y - 2) = True _
                    And checkNoColor(TOP_X_L - 1, TOP_Y - 3) = True _
                    Then
                        checkColor_Left = True
                    End If
                Case 1
                    If checkNoColor(TOP_X_L - 1, TOP_Y) = True _
                    Then
                        checkColor_Left = True
                    End If
            End Select
        Case 3
            Select Case ROTATE_NUM
                Case 0
                    If checkNoColor(TOP_X_L - 1, TOP_Y) = True _
                    And checkNoColor(TOP_X_L - 1, TOP_Y - 1) = True _
                    Then
                        checkColor_Left = True
                    End If
                Case 1
                    If checkNoColor(TOP_X_L - 1, TOP_Y) = True _
                    And checkNoColor(TOP_X_L - 1, TOP_Y - 1) = True _
                    And checkNoColor(TOP_X_L - 1, TOP_Y - 2) = True _
                    Then
                        checkColor_Left = True
                    End If
                Case 2
                    If checkNoColor(TOP_X_L + 1, TOP_Y) = True _
                    And checkNoColor(TOP_X_L - 1, TOP_Y - 1) = True _
                    Then
                        checkColor_Left = True
                    End If
                Case 3
                    If checkNoColor(TOP_X_L - 1, TOP_Y) = True _
                    And checkNoColor(TOP_X_L, TOP_Y - 1) = True _
                    And checkNoColor(TOP_X_L, TOP_Y - 2) = True _
                    Then
                        checkColor_Left = True
                    End If
            End Select
        Case 4
            Select Case ROTATE_NUM
                Case 0
                    If checkNoColor(TOP_X_L - 1, TOP_Y) = True _
                    And checkNoColor(TOP_X_L + 1, TOP_Y - 1) = True _
                    Then
                        checkColor_Left = True
                    End If
                Case 1
                    If checkNoColor(TOP_X_L - 1, TOP_Y) = True _
                    And checkNoColor(TOP_X_L - 1, TOP_Y - 1) = True _
                    And checkNoColor(TOP_X_L - 1, TOP_Y - 2) = True _
                    Then
                        checkColor_Left = True
                    End If
                Case 2
                    If checkNoColor(TOP_X_L - 1, TOP_Y) = True _
                    And checkNoColor(TOP_X_L - 1, TOP_Y - 1) = True _
                    Then
                        checkColor_Left = True
                    End If
                Case 3
                    If checkNoColor(TOP_X_L, TOP_Y) = True _
                    And checkNoColor(TOP_X_L, TOP_Y - 1) = True _
                    And checkNoColor(TOP_X_L - 1, TOP_Y - 2) = True _
                    Then
                        checkColor_Left = True
                    End If
            End Select
        Case 5
            Select Case ROTATE_NUM
                Case 0
                    If checkNoColor(TOP_X_L - 1, TOP_Y) = True _
                    And checkNoColor(TOP_X_L, TOP_Y - 1) = True _
                    Then
                        checkColor_Left = True
                    End If
                Case 1
                    If checkNoColor(TOP_X_L - 1, TOP_Y) = True _
                    And checkNoColor(TOP_X_L - 1, TOP_Y - 1) = True _
                    And checkNoColor(TOP_X_L - 1, TOP_Y - 2) = True _
                    Then
                        checkColor_Left = True
                    End If
                Case 2
                    If checkNoColor(TOP_X_L, TOP_Y) = True _
                    And checkNoColor(TOP_X_L - 1, TOP_Y - 1) = True _
                    Then
                        checkColor_Left = True
                    End If
                Case 3
                    If checkNoColor(TOP_X_L, TOP_Y) = True _
                    And checkNoColor(TOP_X_L - 1, TOP_Y - 1) = True _
                    And checkNoColor(TOP_X_L, TOP_Y - 2) = True _
                    Then
                        checkColor_Left = True
                    End If
            End Select
        Case 6
            Select Case ROTATE_NUM
                Case 0
                    If checkNoColor(TOP_X_L, TOP_Y) = True _
                    And checkNoColor(TOP_X_L - 1, TOP_Y - 1) = True _
                    Then
                        checkColor_Left = True
                    End If
                Case 1
                    If checkNoColor(TOP_X_L - 1, TOP_Y) = True _
                    And checkNoColor(TOP_X_L - 1, TOP_Y - 1) = True _
                    And checkNoColor(TOP_X_L, TOP_Y - 2) = True _
                    Then
                        checkColor_Left = True
                    End If
            End Select
        Case 7
            Select Case ROTATE_NUM
                Case 0
                    If checkNoColor(TOP_X_L - 1, TOP_Y) = True _
                    And checkNoColor(TOP_X_L, TOP_Y - 1) = True _
                    Then
                        checkColor_Left = True
                    End If
                Case 1
                    If checkNoColor(TOP_X_L, TOP_Y) = True _
                    And checkNoColor(TOP_X_L - 1, TOP_Y - 1) = True _
                    And checkNoColor(TOP_X_L - 1, TOP_Y - 2) = True _
                    Then
                        checkColor_Left = True
                    End If
            End Select
    End Select

End Function

' 隣の色の確認 置ける箇所ならTrue 右方向
Function checkColor_Right(ByVal x As Integer, ByVal y As Integer, ByRef Block As Integer) As Boolean

    checkColor_Right = False
    
    Select Case Block
        Case 1
            If checkNoColor(TOP_X_R + 1, TOP_Y) = True _
            And checkNoColor(TOP_X_R + 1, TOP_Y - 1) = True _
            Then
                checkColor_Right = True
            End If
        Case 2
            Select Case ROTATE_NUM
                Case 0
                    If checkNoColor(TOP_X_R + 1, TOP_Y) = True _
                    And checkNoColor(TOP_X_R + 1, TOP_Y - 1) = True _
                    And checkNoColor(TOP_X_R + 1, TOP_Y - 2) = True _
                    And checkNoColor(TOP_X_R + 1, TOP_Y - 3) = True _
                    Then
                        checkColor_Right = True
                    End If
                Case 1
                    If checkNoColor(TOP_X_R, TOP_Y + 1) = True _
                    And checkNoColor(TOP_X_L - 1, TOP_Y) = True _
                    And checkNoColor(TOP_X_R + 1, TOP_Y) = True _
                    Then
                        checkColor_Right = True
                    End If
            End Select
        Case 3
            Select Case ROTATE_NUM
                Case 0
                    If checkNoColor(TOP_X_R + 1, TOP_Y) = True _
                    And checkNoColor(TOP_X_R - 1, TOP_Y - 1) = True _
                    Then
                        checkColor_Right = True
                    End If
                Case 1
                    If checkNoColor(TOP_X_R, TOP_Y) = True _
                    And checkNoColor(TOP_X_R, TOP_Y - 1) = True _
                    And checkNoColor(TOP_X_R + 1, TOP_Y - 2) = True _
                    Then
                        checkColor_Right = True
                    End If
                Case 2
                    If checkNoColor(TOP_X_R + 1, TOP_Y) = True _
                    And checkNoColor(TOP_X_R + 1, TOP_Y - 1) = True _
                    Then
                        checkColor_Right = True
                    End If
                Case 3
                    If checkNoColor(TOP_X_R + 1, TOP_Y) = True _
                    And checkNoColor(TOP_X_R + 1, TOP_Y - 1) = True _
                    And checkNoColor(TOP_X_R + 1, TOP_Y - 2) = True _
                    Then
                        checkColor_Right = True
                    End If
            End Select
        Case 4
            Select Case ROTATE_NUM
                Case 0
                    If checkNoColor(TOP_X_R + 1, TOP_Y) = True _
                    And checkNoColor(TOP_X_R + 1, TOP_Y - 1) = True _
                    Then
                        checkColor_Right = True
                    End If
                Case 1
                    If checkNoColor(TOP_X_R + 1, TOP_Y) = True _
                    And checkNoColor(TOP_X_R, TOP_Y - 1) = True _
                    And checkNoColor(TOP_X_R, TOP_Y - 2) = True _
                    Then
                        checkColor_Right = True
                    End If
                Case 2
                    If checkNoColor(TOP_X_R - 1, TOP_Y) = True _
                    And checkNoColor(TOP_X_R + 1, TOP_Y - 1) = True _
                    Then
                        checkColor_Right = True
                    End If
                Case 3
                    If checkNoColor(TOP_X_R + 1, TOP_Y) = True _
                    And checkNoColor(TOP_X_R + 1, TOP_Y - 1) = True _
                    And checkNoColor(TOP_X_R + 1, TOP_Y - 2) = True _
                    Then
                        checkColor_Right = True
                    End If
            End Select
        Case 5
            Select Case ROTATE_NUM
                Case 0
                    If checkNoColor(TOP_X_R + 1, TOP_Y) = True _
                    And checkNoColor(TOP_X_R, TOP_Y - 1) = True _
                    Then
                        checkColor_Right = True
                    End If
                Case 1
                    If checkNoColor(TOP_X_R, TOP_Y) = True _
                    And checkNoColor(TOP_X_R + 1, TOP_Y - 1) = True _
                    And checkNoColor(TOP_X_R, TOP_Y - 2) = True _
                    Then
                        checkColor_Right = True
                    End If
                Case 2
                    If checkNoColor(TOP_X_R, TOP_Y) = True _
                    And checkNoColor(TOP_X_R + 1, TOP_Y - 1) = True _
                    Then
                        checkColor_Right = True
                    End If
                Case 3
                    If checkNoColor(TOP_X_R + 1, TOP_Y) = True _
                    And checkNoColor(TOP_X_R + 1, TOP_Y - 1) = True _
                    And checkNoColor(TOP_X_R + 1, TOP_Y - 2) = True _
                    Then
                        checkColor_Right = True
                    End If
            End Select
        Case 6
            Select Case ROTATE_NUM
                Case 0
                    If checkNoColor(TOP_X_R, TOP_Y - 1) = True _
                    And checkNoColor(TOP_X_R + 1, TOP_Y) = True _
                    Then
                        checkColor_Right = True
                    End If
                Case 1
                    If checkNoColor(TOP_X_R, TOP_Y) = True _
                    And checkNoColor(TOP_X_R + 1, TOP_Y - 1) = True _
                    And checkNoColor(TOP_X_R + 1, TOP_Y - 2) = True _
                    Then
                        checkColor_Right = True
                    End If
            End Select
        Case 7
            Select Case ROTATE_NUM
                Case 0
                    If checkNoColor(TOP_X_R, TOP_Y) = True _
                    And checkNoColor(TOP_X_R + 1, TOP_Y - 1) = True _
                    Then
                        checkColor_Right = True
                    End If
                Case 1
                    If checkNoColor(TOP_X_R + 1, TOP_Y) = True _
                    And checkNoColor(TOP_X_R + 1, TOP_Y - 1) = True _
                    And checkNoColor(TOP_X_R, TOP_Y - 2) = True _
                    Then
                        checkColor_Right = True
                    End If
            End Select
    End Select

End Function


' 隣の色の確認 置ける箇所ならTrue 下方向
Function checkColor_Down(ByVal x As Integer, ByVal y As Integer, ByRef Block As Integer) As Boolean

    checkColor_Down = False
    
    Select Case Block
        Case 1
            If checkNoColor(TOP_X_L, TOP_Y + 1) = True _
            And checkNoColor(TOP_X_R, TOP_Y + 1) = True _
            Then
                checkColor_Down = True
            End If
        Case 2
            Select Case ROTATE_NUM
                Case 0
                    If checkNoColor(TOP_X_L, TOP_Y + 1) = True _
                    Then
                        checkColor_Down = True
                    End If
                Case 1
                    If checkNoColor(TOP_X_L, TOP_Y + 1) = True _
                    And checkNoColor(TOP_X_L + 1, TOP_Y + 1) = True _
                    And checkNoColor(TOP_X_L + 2, TOP_Y + 1) = True _
                    And checkNoColor(TOP_X_R, TOP_Y + 1) = True _
                    Then
                        checkColor_Down = True
                    End If
            End Select
        Case 3
            Select Case ROTATE_NUM
                Case 0
                    If checkNoColor(TOP_X_L, TOP_Y + 1) = True _
                    And checkNoColor(TOP_X_L + 1, TOP_Y + 1) = True _
                    And checkNoColor(TOP_X_R, TOP_Y + 1) = True _
                    Then
                        checkColor_Down = True
                    End If
                Case 1
                    If checkNoColor(TOP_X_L, TOP_Y + 1) = True _
                    And checkNoColor(TOP_X_R, TOP_Y - 1) = True _
                    Then
                        checkColor_Down = True
                    End If
                Case 2
                    If checkNoColor(TOP_X_L, TOP_Y) = True _
                    And checkNoColor(TOP_X_L + 1, TOP_Y) = True _
                    And checkNoColor(TOP_X_R, TOP_Y + 1) = True _
                    Then
                        checkColor_Down = True
                    End If
                Case 3
                    If checkNoColor(TOP_X_L, TOP_Y + 1) = True _
                    And checkNoColor(TOP_X_R, TOP_Y + 1) = True _
                    Then
                        checkColor_Down = True
                    End If
            End Select
        Case 4
            Select Case ROTATE_NUM
                Case 0
                    If checkNoColor(TOP_X_L, TOP_Y + 1) = True _
                    And checkNoColor(TOP_X_L + 1, TOP_Y + 1) = True _
                    And checkNoColor(TOP_X_R, TOP_Y + 1) = True _
                    Then
                        checkColor_Down = True
                    End If
                Case 1
                    If checkNoColor(TOP_X_L, TOP_Y + 1) = True _
                    And checkNoColor(TOP_X_R, TOP_Y + 1) = True _
                    Then
                        checkColor_Down = True
                    End If
                Case 2
                    If checkNoColor(TOP_X_L, TOP_Y + 1) = True _
                    And checkNoColor(TOP_X_L + 1, TOP_Y) = True _
                    And checkNoColor(TOP_X_R, TOP_Y) = True _
                    Then
                        checkColor_Down = True
                    End If
                Case 3
                    If checkNoColor(TOP_X_L, TOP_Y - 1) = True _
                    And checkNoColor(TOP_X_R, TOP_Y + 1) = True _
                    Then
                        checkColor_Down = True
                    End If
            End Select
        Case 5
            Select Case ROTATE_NUM
                Case 0
                    If checkNoColor(TOP_X_L, TOP_Y + 1) = True _
                    And checkNoColor(TOP_X_L + 1, TOP_Y + 1) = True _
                    And checkNoColor(TOP_X_R, TOP_Y + 1) = True _
                    Then
                        checkColor_Down = True
                    End If
                Case 1
                    If checkNoColor(TOP_X_L, TOP_Y + 1) = True _
                    And checkNoColor(TOP_X_R, TOP_Y) = True _
                    Then
                        checkColor_Down = True
                    End If
                Case 2
                    If checkNoColor(TOP_X_L, TOP_Y) = True _
                    And checkNoColor(TOP_X_L + 1, TOP_Y + 1) = True _
                    And checkNoColor(TOP_X_R, TOP_Y) = True _
                    Then
                        checkColor_Down = True
                    End If
                Case 3
                    If checkNoColor(TOP_X_L, TOP_Y) = True _
                    And checkNoColor(TOP_X_R, TOP_Y + 1) = True _
                    Then
                        checkColor_Down = True
                    End If
            End Select
        Case 6
            Select Case ROTATE_NUM
                Case 0
                    If checkNoColor(TOP_X_L, TOP_Y) = True _
                    And checkNoColor(TOP_X_L + 1, TOP_Y + 1) = True _
                    And checkNoColor(TOP_X_R, TOP_Y + 1) = True _
                    Then
                        checkColor_Down = True
                    End If
                Case 1
                    If checkNoColor(TOP_X_L, TOP_Y + 1) = True _
                    And checkNoColor(TOP_X_R, TOP_Y) = True _
                    Then
                        checkColor_Down = True
                    End If
            End Select
        Case 7
            Select Case ROTATE_NUM
                Case 0
                    If checkNoColor(TOP_X_L, TOP_Y + 1) = True _
                    And checkNoColor(TOP_X_L + 1, TOP_Y + 1) = True _
                    And checkNoColor(TOP_X_R, TOP_Y) = True _
                    Then
                        checkColor_Down = True
                    End If
                Case 1
                    If checkNoColor(TOP_X_L, TOP_Y) = True _
                    And checkNoColor(TOP_X_R, TOP_Y + 1) = True _
                    Then
                        checkColor_Down = True
                    End If
            End Select
    End Select

End Function

' 指定セルの色がデフォルトの色か デフォルトの色ならTrue
Public Function checkNoColor(ByVal x As Integer, ByVal y As Integer) As Boolean
    
    Dim color
    
    color = Worksheets(TETRIS_SHEET).Cells(y, x).Interior.color
    
    If color = RGB(255, 255, 255) Then
        checkNoColor = True
    Else
        checkNoColor = False
    End If

End Function

つぎにブロックの回転ですが（これ結構悩んだんですが）一番早いのがブロックごとにパターンをつくってセルに描くことです。

順に説明しますと、ブロックの回転は「Ctrl」キーで回転するようにしていますが、

その「Ctrl」キーの入力イベントを検知した後、「Ctrl」キーが押された回数を変数 ROTATE_NUM にもたせます。

例えば「Ctrl」キーが２回入力されれば ROTATE_NUM = 2となります。そして、ブロック名が「2」で ROTATE_NUM = 2 なら「こう描く！」と決めておきます。

※具体的には下記表のようにパターン化します。

あとは上記表の組み合わせをガリガリ書くだけです（これが書き間違えなどあって大変でしたね、、、）。

ソースコード

Option Explicit

' ブロック 回転
Sub rotateBlock(ByRef x As Integer, ByRef y As Integer, ByRef Block As Integer)
    
    Dim tmp_ROTATE_NUM
    
    Call deleteRandBlock(x, y, Block)
    
    Select Case Block
        Case 2, 6, 7
            If ROTATE_NUM = 0 Then
                tmp_ROTATE_NUM = ROTATE_NUM + 1
            Else
                tmp_ROTATE_NUM = 0
            End If
        Case 3, 4, 5
            If ROTATE_NUM <> 3 Then
                tmp_ROTATE_NUM = ROTATE_NUM + 1
            Else
                tmp_ROTATE_NUM = 0
            End If
    End Select
    
    ' 回転できるか確認
    If checkRotateBlock(x, y, Block) = True Then
        
        ' 端っこで回転させる場合、ブロックをずらす
        If Block = 2 And TOP_X_R = BOTTOM_X_RIGHT - 1 And ROTATE_NUM = 0 Then x = BOTTOM_X_RIGHT - 4
        If Block = 2 And TOP_X_R <= BOTTOM_X_LEFT + 2 And ROTATE_NUM = 0 Then x = BOTTOM_X_LEFT + 1
        If Block = 3 And TOP_X_R = BOTTOM_X_RIGHT - 1 And ROTATE_NUM = 1 Then x = BOTTOM_X_RIGHT - 3
        If Block = 4 And TOP_X_R = BOTTOM_X_RIGHT - 1 And ROTATE_NUM = 1 Then x = BOTTOM_X_RIGHT - 3
        If Block = 6 And TOP_X_R = BOTTOM_X_RIGHT - 1 And ROTATE_NUM = 1 Then x = BOTTOM_X_RIGHT - 3
        If Block = 7 And TOP_X_R = BOTTOM_X_RIGHT - 1 And ROTATE_NUM = 1 Then x = BOTTOM_X_RIGHT - 3
        
        ROTATE_NUM = tmp_ROTATE_NUM
        Call getRandBlock(x, y, Block)
        Call setTopPlace(x, y, Block)
    Else
        Call getRandBlock(x, y, Block)
    End If
    
End Sub

' ブロックが回転できるか できるなら True
Function checkRotateBlock(ByVal x As Integer, ByVal y As Integer, ByRef Block As Integer)
    
    checkRotateBlock = False
    
    Select Case Block
        Case 1
            checkRotateBlock = checkRotateBlock1(x, y)
        Case 2
            checkRotateBlock = checkRotateBlock2(x, y)
        Case 3
            checkRotateBlock = checkRotateBlock3(x, y)
        Case 4
            checkRotateBlock = checkRotateBlock4(x, y)
        Case 5
            checkRotateBlock = checkRotateBlock5(x, y)
        Case 6
            checkRotateBlock = checkRotateBlock6(x, y)
        Case 7
            checkRotateBlock = checkRotateBlock7(x, y)
    End Select

End Function

' 正方形　ブロックが回転できるか できるなら True
Function checkRotateBlock1(ByVal x As Integer, ByVal y As Integer) As Boolean
    
    checkRotateBlock1 = True
    
    Const color As Integer = BLOCK1_COLOR
    
    If checkNoColor(color, x + 1, y) = False _
    Or checkNoColor(x + 2, y) = False _
    Or checkNoColor(x + 1, y - 1) = False _
    Or checkNoColor(x + 2, y - 1) = False _
    Then
        checkRotateBlock1 = False
    End If

End Function

' 長方形　ブロックが回転できるか できるなら True
Function checkRotateBlock2(ByVal x As Integer, ByVal y As Integer)

    checkRotateBlock2 = True
    
    Const color As Integer = BLOCK2_COLOR
    
    If ROTATE_NUM = 1 Then
        If checkNoColor(x + 2, y) = False _
        Or checkNoColor(x + 2, y - 1) = False _
        Or checkNoColor(x + 2, y - 2) = False _
        Or checkNoColor(x + 2, y - 3) = False _
        Then
            checkRotateBlock2 = False
        End If

    Else
        If checkNoColor(x, y - 2) = False _
        Or checkNoColor(x + 1, y - 2) = False _
        Or checkNoColor(x + 2, y - 2) = False _
        Or checkNoColor(x + 3, y - 2) = False _
        Then
            checkRotateBlock2 = False
        End If

    End If
    
End Function

' L字　ブロックが回転できるか できるなら True
Function checkRotateBlock3(ByVal x As Integer, ByVal y As Integer)
    
    checkRotateBlock3 = True
    
    Const color As Integer = BLOCK3_COLOR
    
    If ROTATE_NUM = 0 Then
        If checkNoColor(x, y) = False _
        Or checkNoColor(x, y - 1) = False _
        Or checkNoColor(x, y - 2) = False _
        Or checkNoColor(x + 1, y - 2) = False _
        Then
            checkRotateBlock3 = False
        End If

    ElseIf ROTATE_NUM = 1 Then
        If checkNoColor(x, y - 1) = False _
        Or checkNoColor(x + 1, y - 1) = False _
        Or checkNoColor(x + 2, y - 1) = False _
        Or checkNoColor(x + 2, y) = False _
        Then
            checkRotateBlock3 = False
        End If

    ElseIf ROTATE_NUM = 2 Then
        If checkNoColor(x, y) = False _
        Or checkNoColor(x + 1, y) = False _
        Or checkNoColor(x + 1, y - 1) = False _
        Or checkNoColor(x + 1, y - 2) = False _
        Then
            checkRotateBlock3 = False
        End If

    Else
        If checkNoColor(x, y) = False _
        Or checkNoColor(x + 1, y) = False _
        Or checkNoColor(x + 2, y) = False _
        Or checkNoColor(x, y - 1) = False _
        Then
            checkRotateBlock3 = False
        End If

    End If
    
End Function

' 逆L字　ブロックが回転できるか できるなら True
Function checkRotateBlock4(ByVal x As Integer, ByVal y As Integer)
    
    checkRotateBlock4 = True
    
    Const color As Integer = BLOCK4_COLOR
    
    If ROTATE_NUM = 0 Then
        If checkNoColor(x, y) = False _
        Or checkNoColor(x, y - 1) = False _
        Or checkNoColor(x, y - 2) = False _
        Or checkNoColor(x + 1, y) = False _
        Then
            checkRotateBlock4 = False
        End If

    ElseIf ROTATE_NUM = 1 Then
        If checkNoColor(x, y) = False _
        Or checkNoColor(x, y - 1) = False _
        Or checkNoColor(x + 1, y - 1) = False _
        Or checkNoColor(x + 2, y - 1) = False _
        Then
            checkRotateBlock4 = False
        End If
    ElseIf ROTATE_NUM = 2 Then
        If checkNoColor(x, y - 2) = False _
        Or checkNoColor(x + 1, y) = False _
        Or checkNoColor(x + 1, y - 1) = False _
        Or checkNoColor(x + 1, y - 2) = False _
        Then
            checkRotateBlock4 = False
        End If
    Else
        If checkNoColor(x, y) = False _
        Or checkNoColor(x + 1, y) = False _
        Or checkNoColor(x + 2, y) = False _
        Or checkNoColor(x + 2, y - 1) = False _
        Then
            checkRotateBlock4 = False
        End If
    End If
    
End Function

' 山　ブロックが回転できるか できるなら True
Function checkRotateBlock5(ByVal x As Integer, ByVal y As Integer)
    
    checkRotateBlock5 = True
    
    Const color As Integer = BLOCK5_COLOR
    
    If ROTATE_NUM = 0 Then
        If checkNoColor(x + 1, y) = False _
        Or checkNoColor(x + 1, y - 1) = False _
        Or checkNoColor(x + 1, y - 2) = False _
        Or checkNoColor(x + 2, y - 1) = False _
        Then
            checkRotateBlock5 = False
        End If
    ElseIf ROTATE_NUM = 1 Then
        If checkNoColor(x, y - 1) = False _
        Or checkNoColor(x + 1, y - 1) = False _
        Or checkNoColor(x + 2, y - 1) = False _
        Or checkNoColor(x + 1, y) = False _
        Then
            checkRotateBlock5 = False
        End If
    ElseIf ROTATE_NUM = 2 Then
        If checkNoColor(x, y - 1) = False _
        Or checkNoColor(x + 1, y) = False _
        Or checkNoColor(x + 1, y - 1) = False _
        Or checkNoColor(x + 1, y - 2) = False _
        Then
            checkRotateBlock5 = False
        End If
    Else
        If checkNoColor(x, y - 1) = False _
        Or checkNoColor(x + 1, y - 1) = False _
        Or checkNoColor(x + 1, y - 2) = False _
        Or checkNoColor(x + 2, y - 1) = False _
        Then
            checkRotateBlock5 = False
        End If
    End If
    
End Function

' Z字　ブロックが回転できるか できるなら True
Function checkRotateBlock6(ByVal x As Integer, ByVal y As Integer)
    
    checkRotateBlock6 = True
    
    Const color As Integer = BLOCK6_COLOR
    
    If ROTATE_NUM = 0 Then
        If checkNoColor(x, y) = False _
        Or checkNoColor(x, y - 1) = False _
        Or checkNoColor(x + 1, y - 1) = False _
        Or checkNoColor(x + 1, y - 2) = False _
        Then
            checkRotateBlock6 = False
        End If
    Else
        If checkNoColor(x, y - 1) = False _
        Or checkNoColor(x + 1, y) = False _
        Or checkNoColor(x + 1, y - 1) = False _
        Or checkNoColor(x + 2, y) = False _
        Then
            checkRotateBlock6 = False
        End If
    End If
    
End Function

' 逆Z字　ブロックが回転できるか できるなら True
Function checkRotateBlock7(ByVal x As Integer, ByVal y As Integer)
    
    checkRotateBlock7 = True
    
    Const color As Integer = BLOCK7_COLOR
    
    If ROTATE_NUM = 0 Then
        If checkNoColor(x, y - 1) = False _
        Or checkNoColor(x, y - 2) = False _
        Or checkNoColor(x + 1, y) = False _
        Or checkNoColor(x + 1, y - 1) = False _
        Then
            checkRotateBlock7 = False
        End If
    Else
        If checkNoColor(x, y) = False _
        Or checkNoColor(x + 1, y) = False _
        Or checkNoColor(x + 1, y - 1) = False _
        Or checkNoColor(x + 2, y - 1) = False _
        Then
            checkRotateBlock7 = False
        End If
        
    End If
    
End Function

ブロックが一行並べば消す

ブロックの移動が完了すれば次は、ブロックが一行そろっているか確認し、そろっている場合はその行を削除してスコアに加算します。

ソースコード

' ブロックの1列ブロックが削除できるところか
Sub checkRowBlock()
    
    Dim x, y, n: n = BOTTOM_Y
    Dim nocolor As Integer
    Dim flag
    Dim Score_num: Score_num = 0
    Dim cellcolor1, cellcolor2
    
    ' そろっている行をグレーにする
    For y = BOTTOM_Y - 1 To START_Y Step -1
        nocolor = 0
        For x = BOTTOM_X_LEFT + 1 To BOTTOM_X_RIGHT - 1 Step 1
            If checkNoColor(x, y) = True Then
              nocolor = nocolor + 1
            End If
        Next x
        If nocolor = BOTTOM_X_RIGHT - BOTTOM_X_LEFT - 1 Then
            Exit For
        ElseIf nocolor = 0 Then
            flag = 1
            For x = BOTTOM_X_LEFT + 1 To BOTTOM_X_RIGHT - 1 Step 1
                With Worksheets(TETRIS_SHEET).Cells(y, x)
                    .Interior.color = RGB(192, 192, 192)
                    .Borders.LineStyle = xlContinuous
                End With
            Next x
        End If
    Next y
    
    ' グレーの行を削除
    If flag = 1 Then
        Application.ScreenUpdating = False
        For y = BOTTOM_Y - 1 To START_Y Step -1
            cellcolor1 = Worksheets(TETRIS_SHEET).Cells(y, BOTTOM_X_LEFT + 1).Interior.color
            If cellcolor1 = RGB(192, 192, 192) Then
                Score_num = Score_num + 1
                For n = y To START_Y Step -1
                    For x = BOTTOM_X_LEFT + 1 To BOTTOM_X_RIGHT - 1
                        With Worksheets(TETRIS_SHEET).Cells(n, x)
                            .ClearFormats
                            .Interior.color = Worksheets(TETRIS_SHEET).Cells(n - 1, x).Interior.color
                        End With
                        If checkNoColor(x, n - 1) = False Then
                            With Worksheets(TETRIS_SHEET).Cells(n, x)
                                .Borders.LineStyle = xlContinuous
                            End With
                        End If
                    Next x
                Next n
            End If
            cellcolor1 = Worksheets(TETRIS_SHEET).Cells(y, BOTTOM_X_LEFT + 1).Interior.color
            If cellcolor1 = RGB(192, 192, 192) Then
                y = y + 1
            End If
        Next y
        Application.ScreenUpdating = False
     End If
     
     If Score_num > 0 Then
         Score = Score + 100 + Score_num * 300
     End If
     
     Worksheets(TETRIS_SHEET).Cells(SCORE_POSITION_Y, SCORE_POSITION_X).Value = Score
      
End Sub

テトリスの終了条件をつける

あとは終了条件だけですね。ある行を天井と決め、その行よりも一つ上の行を端から端までセルの書式を確認し、ブロックがあれば（セルに色がついてあれば）メッセージを表示させ終了させます。

ソースコード

' ゲーム終了
Private Sub checkgame()
    
    Dim x

    For x = BOTTOM_X_LEFT + 1 To BOTTOM_X_RIGHT - 1
        If checkNoColor(x, START_Y - 1) = False Then
          MsgBox "Game Over!" & Chr(13) & "Score : " & Score
          End
        End If
    Next x

End Sub

最後に

いかがでしょうか？

長々と失礼しました。この記事49000文字近くまでいってました、、、まあ大半がソースコードですが。

これ思ったより作るのめんどくさかったですね。。けれどゲームをつくるのってやっぱり楽しいです。

皆様もよければぜひ参考に作ってみてください！

最後にこのテトリスが気になる人もしくは作成したテトリスを参考にしたい人がいれば、ぜひダウンロードしてみてください！

前回は Excel vba でオセロを作成しましたがそのときは１日でサクサク作れたため、調子にのって将棋をつくろうとしたら一週間もかかってしまいました...

苦労した点はものすごくありますが、とにかく働きながらつくるのが大変でしたね。

帰るのが 9時、10時でそっから作るってこと本当に大変....

まあそんな話どうでもいいので、「マウスクリックのイベント検知する方法」については知らないとどうしようもないので、やり方について別記事にまとめようと思います。

※ クリック検知を行う方法については下記になります。ぜひ参考にしてください。

【Excel vba】マウスの左クリックのイベントを検知する簡単な方法

2019.2.4

はじめに Excelで将棋のゲームをつくろうとしたときでした。 そういやどうやってマウスクリックを検知すればいいんやろう？ 私は仕事やブログでExcelを取り扱うことが多いですが、セルをクリックしたときにクリックしたことを検知しそこから処理を開始することがわかりませんでした。 いろいろ調べましたが、...

今回はこのページでは作成した Excel 将棋ファイルについて、その操作方法についてご紹介します。

将棋の作成方法については、別記事でご紹介します（作成中といいつつあまり進んでないのでがんばります。。）

※ Excel 将棋ファイルについて下記からダウンロード可能です。

操作方法

ここでは、ダウンロードしたエクセルについて説明します。

ゲームの開始と終了

将棋を始める際は「ゲーム開始」ボタンを押下し、ゲームを終了する場合は「ゲーム終了」を押下します。

また、「ゲーム開始」ボタンを押下するとセル番号 Q2の位置の表示が「ゲーム中」、「ゲーム開始」ボタンを押下すると「開始待ち」となります。

つまり、この表示が「ゲーム中」の場合はゲームがプレイでき、「開始待ち」の場合はゲームがプレイできません。

駒の操作方法

基本はマウス操作になります。

動かしたい駒をクリックすると選択セルが黄色に変化なり、移動できる駒の箇所が薄い黄色になります。

そして移動できる駒の箇所にクリックすることで駒が移動できます。

また持ち駒の処理についても同様に持ち駒から置きたい駒が黄色になり、置ける箇所が薄い黄色になります。

また今回「二歩」の処理を行っております。「二歩」とは同じ列も自分の「歩」の駒を２つ以上は置けないという将棋のルールですが、

元々自分の「歩」の駒がある列に持ち駒から「歩」を置こうとしても置けないようにしています。

具体的には、作成した Excel ファイルでは駒を置ける箇所が薄い黄色をしていますが、そこで「二歩」になるセルに色をつけないように設定しています。

勝敗について

将棋の勝敗はルール上は「王」がとられた時点で終了ですが、

実際に将棋での勝敗が付くケースは、

相手が投了するか「王」が詰む（「王」がどこに動いても次に相手の駒にとられてしまう）状態で

勝敗が付く場合しかないです。

私もかなり昔に将棋をやっていてアマチュア初段をとったことがありますが、「王」がとられて「負けました～」って言っている人は見たことがありません。

なので、本当は「王」が詰む状態で勝敗をつけたいところですが、今回は「王」をとった場合に勝敗が決まるようにしています。

先手後手について

先手後手についてですが、文字が反転していないほうが先手で反転しているほうが後手です。

後手から始めたいということは、このExcel ファイルでは今のところできません（機能追加予定。。）

王手について

自分もしくは相手の「王」の駒が次で相手にとれますよ～という状態が王手ですが、

もし王手の状態になるとメッセージが表示されるようになっています。

本来は王手なら「王」を動かさないといけないのですが、

今回の Excel ファイルでは「王手」の状態でも「王」以外の駒も動けます。

なので、、まあメッセージだけなんですが、「王手」のときは「王」を動かすようにしてください。。

あと、「打ち歩詰め」という「王」が詰む（つまり「王」が動かない、どうやっても次に相手の駒にとられてしまう）場合に「歩」を打って詰ませると反則になるというルールがありますが、

それができていません（将棋の経験があるにもかかわらず完全に忘れていました。）ので

これについては、機能追加する予定です。

最後に

いかがでしたでしょうか？

ぜひ、Excel で将棋をやってみて将棋のおもしろさというか Excel ってなんでもできるなあと実感していただければと思います。

また似たようなやつで 「Excel でオセロをつくってみた」もありますので、そちらも暇ならぜひご参照ください。

Excelでゲームをつくろう！ ～オセロ～（操作編）【Excel vba】

2018.11.21

「Excel vba をつかってゲームを作ってみよう！」の第一弾「2人用オセロ」です。 「Excel でいろいろなゲームをつくってみたい」という思いで、仕事終わりにがんばって作成しました。 みなさまに...

「Excel vba をつかってゲームを作ってみよう！」の第一弾「2人用オセロ」です。

私は仕事の都合上Excelでの作業が非常に多く「Excel でいろいろなゲームをつくってみたいな～」という思っていました。

そして仕事終わりに、毎日時間を空けてがんばって作成しました。

みなさまにもぜひこのオセロゲームで遊んでいただき、「Excel は本当になんでもできるな」と実感していただければと思います。

作成したExcelファイルは以下になります。※ 2019年1月19日 機能追加 & ソースコード一部修正

このページでは、オセロの実装について詳細は記載しておりません。実装方法については下記になります（随時更新いたします）。

画像なしの オセロ Excel ファイル （2019/1/19 追加）

今回、オセロの石（白色、黒色）について、画像を配置することで処理を行っております。

先日画像処理なしで文字「●」「〇」で行う方法について、お問い合わせをいただきました（お問い合わせいただき誠にありがとうございます）。

このページでは、画像なしの Excel ファイルについての説明は行いませんが、文字「●」「〇」で実装した Excel ファイルは下記になります。

ルール

① ルールは普通のオセロ

➁ 二人用（CPU なし）

③ 移動キーと「Enter」キーだけで簡単操作！

④ 先攻は「黒」、ただし「パス」ボタンを押せば手番が「黒」→「白」に変更可能

操作方法

①「ゲーム開始」ボタンでオセロ開始

➁「ゲーム終了」ボタンでオセロ終了

③「パス」ボタンで手番を変更 （例）「黒」→ 「白」、「白」→ 「黒」

④「←」「↑」「↓」「→」キー : セルを移動

⑤「Enter」キー :  オセロの石を置く

遊び方

① 「ゲーム開始」ボタンを押してください。

➁  緑色のオセロ盤で、「←」「↑」「↓」「→」キーを押してオセロの石を置きたいセルに移動してください。

※ マウスでセルを選択してもOKです！

③   「Enter」 キーを押してください。手番の（「黒」の）石が置かれます。

※ 石が反転しない位置もしくは緑色のオセロ盤以外のセルで「Enter」 キーを押しても反転しません。

④  試合が終わるとメッセージが表示されゲームが終了します。

その他の仕様

石が置けなくなった場合は、メッセージが表示され自動でパスされます。

※ どうでもいいですが、下はオセロでの最速パス盤面です。

石が途中で置けなくなるか、すべてのオセロ盤に石が置かれた時点でゲームが終了します。

※ こちらも最速全滅盤面らしいです。

下記注意事項です。これらをしてしまうとエラーメッセージが表示されますのでご注意ください。

最後に

このオセロゲームは作成時間は、４時間～５時間ぐらい。

いずれ CPU 対戦も入れるようにします。レベルとかストーリーもいれるとなお楽しそうと思いましたが、それスマホでよくね？ともなりました。

要するに Excel はデータ収集以外にもゲームもつくれちゃう最強ソフトです。

ぜひ読者のみなさんも Excel を勉強してみてください。

※ オセロの作成方法について

このページでは、作成したオセロの操作方法のみを記載しています。もし作り方を知りたい方は下記リンクを参考ください。