このデジタル時計は Excel Vba という Excel 上でプログラミングをして作成されています。

難しいそうに見えますが、二時間くらいで作れました！（デザインに時間がかかりましたが、こだわりさえしなければ30分で作り終えました）。

処理内容はExcelで現在時刻をデジタル数字フォントで永遠に表示してくれるプログラムです。

ダウンロードできる「Excel デジタル時計」の機能です。

機能といってもボタンが二つあるだけです。

これらのボタンは下記のように動作します。

時刻は一秒ごとに刻まれます。

初期値（はじめに表示されている時刻）は特に気にしなくてもOKです。

このシートには非表示行があります！

このシートには非表示行があります。

この行（33行~43行）はこのデジタル時計を動かすのに重要な役割を担っているので絶対に消さないください！！

さてでは「Excel デジタル時計」の作り方について説明します。

この時計は Excel Vba というプログラミングで作成していきます。

では順に説明します。

※ ここからはプログラミングの専門用語がでてきます！！

現在時刻をカウントする Excel Vba プログラムを作成する

現在時刻をカウントする処理は下記の順に作成していきます。

現在時刻を取得（hh:mm:ss形式）

まず 現在時刻を取得するのに「actWacth」プロシージャを定義します。

このプロシージャでは Format(Time, "hh:mm:ss") を変数 nowValue にセットする処理を実装しています。

Public Sub actWatch()
  nowValue = Format(Time, "hh:mm:ss")
  hour1 = Mid(nowValue, 1, 1) 
  hour2 = Mid(nowValue, 2, 1) 
  minitue1 = Mid(nowValue, 4, 1) 
  minitue2 = Mid(nowValue, 5, 1) 
  second1 = Mid(nowValue, 7, 1) 
  second2 = Mid(nowValue, 8, 1)
End Sub

取得した現在時刻（hh:mm:ss形式）を時間、分、秒で細かく分割

現在時刻が格納されている nowValue（hh:mm:ss形式）を時間、分、秒で細かく分割します（デジタル数字形式にするため）。

この際 Mid 関数という指定した文字を分割する関数を使用します。

Mid関数は開始文字と終了文字を指定することで文字を分割することが可能です。

たとえば 10:51:47 という値の4文字目から5文字目を抽出しようとすると Mid("10:51:47",4,5)と記述します。

すると Mid("10:51:47",4,5) = 「5」となるわけです。

つまり今回の場合はこのようになります。

（例）nowValue = "10:51:47"の場合

時間、分、秒をセルに書き込む

これは簡単です。

時間、分、秒の値を持つ変数（hour1,hour2,minitus1,minitu2,second1,second2）を Cells(行、列)に代入します。

※ PRINT_CELL_ROW、PRINT_CELL_COL は数字の定数です。好きな値にすれば好きなセルの位置に出力されます。

' セルに時間、分、秒を表示させる 
Cells(PRINT_CELL_ROW, PRINT_CELL_COL) = hour1 
Cells(PRINT_CELL_ROW, PRINT_CELL_COL + 1) = hour2 
Cells(PRINT_CELL_ROW, PRINT_CELL_COL + 2) = ":" 
Cells(PRINT_CELL_ROW, PRINT_CELL_COL + 3) = minitue1 
Cells(PRINT_CELL_ROW, PRINT_CELL_COL + 4) = minitue2 
Cells(PRINT_CELL_ROW, PRINT_CELL_COL + 5) = ":" 
Cells(PRINT_CELL_ROW, PRINT_CELL_COL + 6) = second1 
Cells(PRINT_CELL_ROW, PRINT_CELL_COL + 7) = second2

現在時刻を取得する処理を1秒ごとに呼び出す

つぎに現在時刻を取得する処理（「actWacth」プロシージャ）を一秒ごとに呼び出すようにします。

その際、Excel Vba の Application.OnTime という機能を用います。

Application.OnTime Now + timeValue("00:00:01"), "actWacth"

Application.OnTime は 指定した時刻に好きなプロシージャを呼び出すことができます。

つまり、Application.OnTime Now + timeValue("00:00:01"), "プロシージャ" とすることで

指定したプロシージャ（現在時刻を取得する「actWacth」）を1秒ごとに呼び出します。

あとはこれをずっーと実行するだけ。。。それだけです。

今回はずーっと実行する処理として while 文、for 文のようなループ処理ではなく再帰処理にします。

つまり 「actWacth」プロシージャの中に Application.OnTime Now + timeValue("00:00:01"), "actWacth" と書くだけで

ずーっと「actWacth」プロシージャが実行されるというわけです。

Application.OnTime Now を停止させる方法について

現在時刻を取得する「actWacth」を再帰処理で呼び出すと永遠に呼び出されてしまいます。

ですので、ここでは Excel シート上の特定のセルの値（Range(JUDGE_CELL)で指定する値）が TRUE の場合は動作し、FALSEの場合は停止させるよう条件式を追加します。

※ JUDGE_CELL は数字の定数です！値自体は何でもOKです！

 ' 一秒ごとに現在時刻を取得 
If Range(JUDGE_CELL) = True Then 
　　Application.OnTime Now + timeValue("00:00:01"), "actWacth" 
End If

現在時刻をカウントする Excel Vba プログラム（全体）

Const PRINT_CELL_COL As Integer = 43
Const PRINT_CELL_ROW As Integer = 33
Const JUDGE_CELL As String = "AO33"

Public Sub actWacth()

    Dim nowValue As String
    Dim hour1, hour2, minitue1, minitue2, second1, second2
    
    ' 現在時刻を取得
    nowValue = Format(Time, "hh:mm:ss")
    
    ' hh:mm:ss 形式を時間、分、秒に細かく分ける
    hour1 = Mid(nowValue, 1, 1)
    hour2 = Mid(nowValue, 2, 1)
    minitue1 = Mid(nowValue, 4, 1)
    minitue2 = Mid(nowValue, 5, 1)
    second1 = Mid(nowValue, 7, 1)
    second2 = Mid(nowValue, 8, 1)
    
    ' セルに時間、分、秒を表示させる
    Cells(PRINT_CELL_ROW, PRINT_CELL_COL) = hour1
    Cells(PRINT_CELL_ROW, PRINT_CELL_COL + 1) = hour2
    Cells(PRINT_CELL_ROW, PRINT_CELL_COL + 2) = ":"
    Cells(PRINT_CELL_ROW, PRINT_CELL_COL + 3) = minitue1
    Cells(PRINT_CELL_ROW, PRINT_CELL_COL + 4) = minitue2
    Cells(PRINT_CELL_ROW, PRINT_CELL_COL + 5) = ":"
    Cells(PRINT_CELL_ROW, PRINT_CELL_COL + 6) = second1
    Cells(PRINT_CELL_ROW, PRINT_CELL_COL + 7) = second2
    
    ' 一秒ごとに現在時刻を取得
    If Range(JUDGE_CELL) = True Then
    
        Application.OnTime Now + timeValue("00:00:01"), "actWacth"
    
    End If

End Sub

START、STOPボタン用の Excel Vba プログラムを作成する

そして次に START、STOPボタンです。

STARTは startWatch プロシージャで実装します。

Application.OnTime Now（指定したプロシージャを指定した時刻に呼び出す関数）を止めるように用意したセルの値（Range(JUDGE_CELL)で指定する値）を TRUE にし、

actWatch （現在時刻を取得する処理）を呼び出せばOKです。

STOPは Range(JUDGE_CELL) に FALSE を代入するだけです。

Const PRINT_CELL_COL As Integer = 43
Const PRINT_CELL_ROW As Integer = 33
Const JUDGE_CELL As String = "AO33"

Sub startWatch()

    Range(JUDGE_CELL) = True
    
    Call actWacth

End Sub

Sub stopWatch()

    Range(JUDGE_CELL) = False

End Sub

これで現在時刻の表示は完了です！

あとはデジタル数字形式に変換する処理だけです！

数字をデジタル数字形式に表示させる（条件付き書式を設定する）

ここから結構難しい話です。

これはやり方はいろいろあると思いますが、今回は条件付き書式を利用します。

0 ~ 9 の10種類数字があり、そのデジタル数字を思い浮かべてみてください。

そうするとある規則があることに気づきませんか？

たとえばデジタル数字を「上、下、真ん中、左上、左下、右上、右下、」と７つのブロックに区切ります。

すると、ブロック単位で数字ごとにデジタル表記に必要な箇所が決まっているんです。

たとえば、0ならば真ん中以外の6つのブロック、1ならば右上と右下だけの2ブロック、....

こんな感じでブロック単位でみていると数字毎に必要な箇所が固定化されています。

これを表にまとめたのが、右上の表の画像です。

これさえ理解できればあとはこのルールを条件付き書式に反映させればいいだけです。

つまり1の数字ならばセルの右上、右下の部分の色を変えればデジタル数字形式になります！

条件付き書式は設定箇所が多いため今回は設定のやりかただけを説明します。

※ 詳細な条件付き書式の設定はダウンロードした Excel デジタル時計ファイルをご確認ください！

Excel の「ホーム」→「条件付き書式」→「ルールの管理」を押下します。

下記画面が表示されますので、新規ルールをクリックします。

書式ルールの編集画面がでてくるので、一番下の「数式を使用して書式設定するセルを決定」を選択し

「=COUNFIT($AR$37,"*"&AT33&"*")>0」とします（これはあくまで一例です）。

たとえば「3」という数字をデジタル数字形式にする場合「右上、右下、上、下、真ん中」のセルの色を変えればOKということです。

またCOUNTIFは特定の数字が含まれている数をカウントですが、画像右下の表で定義した「値」列に数字が含まれていれば

その「値」列に対応する「位置」列がわかります！あとはそこを条件付き書式で色を変えればOKです！

※ COUNTIF 関数について詳しく知りたい方はこちらもどうぞ！

【Excel 関数】COUNTIF で特定の文字や数値をカウント！

2018.12.2

はじめに Excelで、特定の文字や数字がいくつあるか数えるとき、「COUNTIF」関数をよく使います。 この関数は、Excel 上で資料等まとめるときに大変便利な関数です。 この関数の使用方法について説明します。 COUNTIF 関数 COUNTIF 関数の基本的な使い方と、ちょっとしたテクニッ...

なにもデジタル数字形式にしないならすごく簡単なので、よければぜひつくってみてください！

つくるのがめんどくさいならばぜひダウンロードしてみてください！

どーもTakeです。

このたび兄弟ブログである「スーパー開発ブログ」で Pythonで画像から文字起こしをするサイトをつくりました！！！

記事はこちらです。

このページを作るのがかなり大変でした。。。。

CentOs7というサーバ上で「tesseract-ocr」と「pytesseract」というパッケージを使ってやったんですが、うまくいかないことばかり、、、

なので、構築手順を簡単にページにまとめました！

よければこのページを参考に作ってみてください！

画像から文字起こしするための環境構築

画像から文字起こしするための環境構築の方法について記述します。

この通りやればいけますが、下記を実行してエラーが出たら大抵うまくいきませんので、全部うまくいったことを確認してください。

「tesseract-ocr」と「pytesseract」をインストールする

下記コマンドを実行してパッケージを入れます。

# yum install gcc gcc-c++ make
# yum install autoconf automake libtool
# yum install libjpeg-devel libpng-devel libtiff-devel zlib-devel

つぎに「tesseract-ocr」を実行するために必要な「leptonica」を入れます。

# wget http://www.leptonica.org/source/leptonica-1.76.0.tar.gz
# tar -zxvf leptonica-1.76.0.tar.gz
# ./configure
# make
# make install

つぎに vim コマンドで「/etc/profile」に下記内容を追記します。

export LD_LIBRARY_PATH=$LD_LIBRARY_PAYT:/usr/local/lib 
export LIBLEPT_HEADERSDIR=/usr/local/include 
export PKG_CONFIG_PATH=/usr/local/lib/pkgconfig 
carried out source /etc/profileMake it effective

そんで「tesseract-ocr」を入れます。

git コマンドが入っていない場合「yum install git」で入れます。

# git clone -b master https://github.com/tesseract-ocr/tesseract.git tesseract-ocr
# ./autogen.sh
# ./configure 
# make 
# make install
# ldconfig

「tessdata」で言語パッケージをとってくる

「tessdata」っていう言語パッケージを取ってきます。

下記コマンドを実行します。

git clone https://github.com/tesseract-ocr/tessdata.git
mv tessdata /usr/local/share/tessdata

あとは実際に動くか試してみます。

$ tesseract ims.png out -| jen

上記は「img.png」って画像を読み込ませて「out」（テキストとして出力）されます。

日本語を文字起こししたい場合は jpn で言語指定します。

実行後に「Error」となく実行できればOK、out.txtの中身を確認して正常に動いていれば問題なしです。

ポイント！

「mv tessdata /usr/local/share/tessdata」を絶対に忘れないこと！！！

しかも「cp」コマンド（コピー）ではなく「mv」コマンド（移動）であること！です！

なんでかわからないですが、「cp」コマンドだと旨く読み込まれなかったです。

わたしはそもそも「mv」コマンドを忘れて実行してしまい下のようなエラーがでて私は詰みました笑

# 実行しようとしたときの出来事
$ tesseract ims.png out -| jen
Error in pixReaddenTiff: function not present
Error in pixReadMem: tiff: no pix returned
Error in pixaGenerateFontFromStrina: pix not made
Error in bnfCreate: font pixa not made Tesseract Open Source OCR Engine v5.0.0-alpha-20210401-118-g1c77 with Leptonica
Error in pixReadStreamPng: function not present
Error in pixReadStrean: png: no pix returned
Error in pixRead: pix not read Error during processing

「pytesseract 」をインストールする

ここまでくればあとは「pip install pytesseract 」を実行します。

ここまでエラーなしでいけていればOKです。

参考サイト：

• https://www.programmersought.com/article/70164685281/
• https://github.com/tex2e/ocr-jpn

実際にPythonコードを書いてみる

実際に「tesseract」を python上で動作させます。

下記内容を pythonファイルとして保存（今回は test.py）とします。

from pytesseract import pytesseract
from PIL import Image

# 読み込み対象ファイルの指定
img = Image.open("./img.png", "r")

# tesseractコマンドのインストールパス
pytesseract.tesseract_cmd = "/usr/local/bin/tesseract"

# 文字列として出力できる。
result = pytesseract.image_to_string(img, lang="eng+jpn")

print(result)

そして「python test.py 」と実行すればコマンドライン上に画像に含まれるメッセージが出力されます。

処理の中身は超簡単です。

まず img.png っていう画像ファイルを読み込んで「/usr/local/tesseract」を呼び出して実行して変数に格納し、

その変数を出力するだけのスクリプトです。

最後に

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

Pythonで画像から文字起こしをする方法を解説しました。

わたしの兄弟ブログである「スーパー開発ブログ」のこちらの記事に実際に動作するものが乗っています。

ただ英語は精度がかなりいいんですが、日本語が精度が悪いです。。。

ですが、結構面白いサイトなのでぜひチェックして見てください！

ではでは。

どーも Takeです。久々の投稿です。

いつもたくさんのお問い合わせありがとうございます。そしてなかなか仕事が忙しくて返信できずすみません。。。

この度、新しいブログ「スーパー開発ブログ」を作成しました！

このブログ、なんとWordpressなしでPython の Django というWebフレームワークのみで作成しました！

なぜWordpressなしでブログをつくったのか？

それは「WordPress」だとどうしてもできないことが多かったからです。

WordPressって本当に凄いソフトだと思います。

自動でマークアップもされプラグインもテーマも豊富で世界一のCMSだとも思っています。

しかしIT系のブログを書いていると、文字だけではなく実際にプログラミングが動く記事に乗せたいなと思っていました。

そう思って、目につけたのが私が一番好きな言語である Python であり、Python で一からつくってみよう！と思ったのがすべての始まりです。

Python の Django でブログ作ったら実際どんな感じなん？

苦労話とよかったところをいいます。

まず苦労話

ブログを一からつくるのはめちゃくちゃ時間かかり、死ぬほど大変です。

なんやかんや仕事しながらやっていたら一か月くらいかかりました。

ともかく壁が多すぎる。。。。

サーバの選定

もともとブログ作成にはレンタルサーバーとして Xserver をつかっていたのですが、

今回は思い切って「さくらVPS」をつかってみました。

これは本当に使ってよかったと思いました。

しかし Linux サーバ系の知識がない人には結構ハードルが高いです。

さくらVPSのページがすごくわかりやすく書いていますが、それでもかなり苦労すると思います。

サーバの環境構築（ホスト名、FW設定、Apache設定、SSL設定（https化）、その他ssh接続等）

これが一番大変でした。

ページがつながらない。。https化できない。。

Twtter でシェアできない。。とかとか

なんとか Google 先生の力を借りてやってようやく動くようになりましたが、、自力は無理です。

Python の Django フレームワークの開発（静的ページ、動的ページの設定、SNSタグ設定）

これは思いのほか簡単でした。

だいたいわからないことは調べたらでてきます、しかし量がおおい。。。。

Djangoの仕組みをしっかりと理解する必要があります。

また静的ページ（htmlにべた書きするページ）だけなら正直1日で誰でもできます。

しかし動的ページ（データベースに記事を登録して運用するページ）を取り入れるとその分の設定が必要になり、結構大変でした。

しかも動的ページにPythonからの処理を受け取ってhtml画面に表示させるように実装もしたので、その設定をするのもめちゃくちゃ大変。。。。

ページデザイン（これが死ぬほど大変、スマホでも崩れないように調整作業）

これが二番目に大変でした。

レスポンシブ対応（スマホ対応）の画面にするとどうしてもレイアウト崩れが発生しまくって修正に時間がかなりかかります。

ページデザインは Bootstrap でほぼカバーしましたが、

それでも実現できない箇所は CSS、JQuery でカバーしました。

たぶんまだバグがありそう。。。見つけ次第直します。

つくってよかった点

プログラミング処理が画面表示できるようになった点が本当に嬉しいです。

クライアントサイドの言語（Javascript、JQuery等）ならば WordPressでも正直できますが、

Pythonの処理も画面で表示させれるようになりました！！！

具体的にはこの「【無料・ダウンロードOK】写真から塗り絵（線画）をつくろう！」です。

これはPythonで加工した画像を画面表示しています。本当に作ってよかった！

あとめちゃくちゃ実力つきました！

Linuxの環境設定、Apache、証明書、ssl化、Python、html系フロントの知識。。。。

参考書なんか読むよりもはるかに実力がつきました！！！

出来た感想はやってよかった！！！！

あとはコロナで外出もできなかったのでちょうど暇つぶしできてよかったと思います。

そこからようやくブログ完成！！！スタートライン！！

ようやく完成しました。

これからこのブログと新しいブログ「スーパー開発ブログ」ふたつでいろいろと記事を作っていきたいと思います！！！

つくっていて、「これパッケージにしたら絶対売れるだろうなあ」とか思いました。

本当に WordPress って便利。。。

ではでは。

久々のブログ投稿です（さぼるにさぼってました笑）。

この記事ではマトリックス形式から表形式に変換するマクロの作成方法について簡単に解説します。

これはこのマクロが仕事で必要になったため、自分用に作りました。

もしよければ参考にしてみてください。

※ いつものようにつくったのも共有しときますので、よければどうぞ（ブック保護、シート保護はかかってます）。

マクロの作り方

マトリックス形式から表形式に変換するマクロの作り方を簡単にざっくり説明します。

正直超簡単なので、安心してください。

順にシート構成、VBAのソースコードと説明します。

シート構成

シートは下記４シートから構成されます。

シートの内容について説明します。

※ mainシートは特に重要でないため省きます。

「setting」シート

「setting」シートは非表示シートのため中身が見れません。

非表示にする理由として、値をいじられたくないからです。

このシートでは「matrix」シートの設定内容が Excel 関数で取得できるようになっています。

また Excel 関数が万が一消えたことを想定して Excel マクロ内で記述するように設定しています。

Excel 関数はこんな感じのことが書かれています。

要は「matrix」シートの列と行のデータのはじまりと終わりの位置情報（セルの何行目何列目か）を取得しているだけです。

「matrix」シート

「matrix」シートは入力シートです。

注意点は列名、行名が入っている箇所のみデータが出力される点です。

上記の画面では、列名行名が入力されている赤枠しかデータ出力されないので注意が必要です。

「table」シート

「table」シートは出力シートです。

「matrix」シートに登録されたデータが出力されます。

まあ、それだけです。

ソースコード

作成したマクロのVBA ソースコードは下記になります。

長そうに感じますが、そんな難しい処理はしていません。

コードの簡単な解説はソースコードの下にします。

' ##############################################
' # マトリックス形式から表形式に変更するマクロ
' ##############################################

' シート一覧
Const SHEET_MAIN As String = "main"
Const SHEET_MATRIC As String = "matrix"
Const SHEET_TABLE As String = "table"
Const SHEET_SETTING As String = "setting"

' セル情報
Const CELL_M_C_S As String = "A5"
Const CELL_M_C_E As String = "B5"
Const CELL_M_R_S As String = "C5"
Const CELL_M_R_E As String = "D5"

'メッセージ
Const MSG_ERROR01 As String = "「" & SHEET_MATRIC & "」シートに値を正しく入力してください"
Const MSG_AFTER As String = "「" & SHEET_TABLE & "」シートに出力されました！"

' メイン
Sub main()

    Dim ms As Worksheet
    Dim ts As Worksheet
    Dim ss As Worksheet
    
    Dim mData, mCol, mRow
    
    Call setting(ms, ss, ts)

    Call getMatrixData(mData, mCol, mRow, ms, ss)

    Call setTableData(mData, mCol, mRow, ts)
    
    Call aterSetting

End Sub

' 初期設定
Private Sub setting(ByRef ms, ByRef ss, ByRef ts)
    
    Set ms = Worksheets(SHEET_MATRIC)
    Set ts = Worksheets(SHEET_TABLE)
    Set ss = Worksheets(SHEET_SETTING)
    
    ss.Range(CELL_M_C_S) = "=IFERROR(MATCH(" & """" & "*?" & """" & ",INDEX(matrix!A:A&" & """" & """" & ",0),0),0)"
    ss.Range(CELL_M_C_E).Value = "=IFERROR(COUNTA(matrix!A:A)+1,0)"
    ss.Range(CELL_M_R_S).Value = "=IFERROR(MATCH(" & """" & "*?" & """" & ",INDEX(matrix!1:1&" & """" & """" & ",0),0),0)"
    ss.Range(CELL_M_R_E).Value = "=IFERROR(COUNTA(matrix!1:1)+1,0)"
  
    ts.Cells.ClearContents
    
End Sub

' マトリックスデータ取得
Private Sub getMatrixData(ByRef mData, ByRef mCol, ByRef mRow, ByRef ms, ByRef ss)

    Dim dStartCol, dStartRow
    Dim dEndCol, dEndRow
    
    dStartCol = ss.Range(CELL_M_C_S)
    dStartRow = ss.Range(CELL_M_R_S)
    dEndCol = ss.Range(CELL_M_C_E)
    dEndRow = ss.Range(CELL_M_R_E)
    
    If dStartCol = 0 Or dStartRow = 0 Or dEndCol = 0 Or dEndRow = 0 Then
    
        MsgBox MSG_ERROR01
        End
    
    End If
    
    mRow = ms.Range(ms.Cells(1, dStartRow), ms.Cells(1, dEndRow))
    mCol = ms.Range(ms.Cells(dStartCol, 1), ms.Cells(dEndCol, 1))
    mData = ms.Range(ms.Cells(dStartCol, dStartRow), ms.Cells(dEndCol, dEndRow))

End Sub

' 表形式に書き込み
Private Sub setTableData(ByRef mData, ByRef mCol, ByRef mRow, ByRef ts)

    Application.ScreenUpdating = False

    Dim idx, x, y

    y = 1
    idx = 1
    
    For Each c In mCol
        x = 1
        For Each r In mRow
            ts.Cells(idx, 1) = c
            ts.Cells(idx, 2) = r
            ts.Cells(idx, 3) = mData(y, x)
            idx = idx + 1
            x = x + 1
        Next r
        y = y + 1
    Next c

    Application.ScreenUpdating = True

End Sub

' 後処理
Private Sub aterSetting()
    
    Application.ScreenUpdating = False
    
    MsgBox MSG_AFTER

    Sheets(SHEET_MAIN).Select
    Range("A1").Select
    Sheets(SHEET_MATRIC).Select
    Range("A1").Select
    Sheets(SHEET_TABLE).Select
    Range("A1").Select
    
    Application.ScreenUpdating = True
    
End Sub

ソースコードでは下記のような処理を順にしています。

これがすべてです。めちゃくちゃシンプルなやり方だと思います。

「よくわからん」と思った人もソースコードをよく見ればたぶんなんとかわかると思います（ざっくりですみません。。）

最後に

いかがでしょうか？

今回はマトリックス形式から表形式に変換するマクロの作成方法をご紹介しました。

ブログ書くの楽しいですね。またなんか作ったら投稿します。

なんか作ってほしいマクロがあれば「お問い合わせ」から問い合わせてください。

簡単そうなものならつくります。

ではでは。

どーも 暇人プログラマー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で将棋のゲームをつくろうとしたときでした。

私は仕事やブログでExcelを取り扱うことが多いですが、セルをクリックしたときにクリックしたことを検知しそこから処理を開始することがわかりませんでした。

いろいろ調べましたが、まあ最初はうまくいかなかった、、です。

そんな中私が見つけた一番簡単なクリック検知する方法についてご紹介します。

※話が全く変わりますが、Excel でクリック検知を用いて作成した将棋のゲームは下記リンクです。

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

2019.2.1

エクセルで「2人用将棋」作っちゃいました！！ 前回は Excel vba でオセロを作成しましたがそのときは１日でサクサク作れたため、調子にのって将棋をつくろうとしたら一週間もかかってしまいました... 苦労した点 仕事で疲れすぎて、開発する気力と体力が持たない... マウスクリックのイベント...

クリック検知をする方法

Excel の vba 画面を開き、赤枠のプルダウンメニューを開きます。このとき、VBAProject に「標準モジュール」を選択しないようにしてください。

そしてプルダウンメニューから「Worksheet」を選択します。

するとvba の編集画面に「Worksheet_SelectChange」 というプロシージャがでてきます。

これはクリックを検知するためのプロシージャで、右クリックを検知するためには「Worksheet_SelectChange」プロシージャとなっている必要があります。

また「Worksheet_SelectChange」プロシージャの名前は変更できないのでご注意ください。

もしこのプロシージャが表示されない場合は、右のプルダウンメニューから「SelectionChange」を選択してください。

では実際にクリック検知を行ったvba 処理の例をご紹介します。

例えばシートのあるセルをクリックするとメッセージが表示されるプログラムを作成します。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim NowCell
    Set NowCell = ActiveCell
    
    MsgBox NowCell.Column
    
End Sub

これはクリックしたセルの列番号をメッセージで表示させるプログラムです。

これをクリック処理をしたいシートを選択して vba 編集画面 に貼り付けます。画面では「Sheet1」を選択しています。

そしてシート画面に戻り「Sheet1」の好きなセルを選択してください。

下記画面のようにクリックしたセルの列番号が表示されていることが確認できます。

最後に

いかがでしょうか。

今回はただシートのクリックを検知しそのセルの列番号を表示させるプログラムをご紹介しましたが、「Worksheet_SelectChange」プロシージャの中身を好きなように編集することで、さまざまなプログラムを作成することができます。

ぜひこの技を応用させていろいろなものを作成してみてください。ではでは。

前回は 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 をつかって Excel さえあれば簡単につくれるおみくじについて紹介します！

実際に作ってみた Excel マクロファイルは下記になります。

Excel おみくじの使い方

ダウンロードするとわかると思いますが、「くじを引く」ボタンをクリックすると下の黒枠（B12:B18）に結果が表示されます。

注意点ですがシート名（おみくじ）を変更しないでください。変更すると正常に動作しなくなります。

Excel おみくじの作り方

シート構成と VBA のソースコード（プログラミングの中身）について順にご紹介します。

シート構成

実はこのExcelファイルは２つのシートから構成されています。

「くじマスタ」シートは非表示にしてありますので、確認したい場合はシート名のところを「右クリック」→「再表示」→ 「くじマスタ」を選択し「OK」を押してください。

「おみくじ」シート

おみくじを引くメインのシートです。注意点は結果が表示されるセルの位置（B13:B18）は動かさないようにしてください（タイトルは別に変更してもOKです）。

「くじマスタ」シート

くじの結果を登録しているシートです。

動作概要

動作概要ですが、下記のようになります。

ソースコード

Const MASTERSHEET As String = "くじマスタ"
Const OUTPUTSHEET As String = "おみくじ"
Const OUTPUTCELL As String = "B12"

Sub おみくじ()
 
    Dim result As Integer: result = Int(Rnd * 6)
    Dim omikuzi() As String: ReDim omikuzi(0)
     
    For i = 2 To getMaxRow(MASTERSHEET, "A")
        omikuzi(UBound(omikuzi)) = Worksheets(MASTERSHEET).Cells(i, 2).Value
        ReDim Preserve omikuzi(UBound(omikuzi) + 1)
    Next i
    ReDim Preserve omikuzi(UBound(omikuzi) - 1)
    
    
    Worksheets(OUTPUTSHEET).Range(OUTPUTCELL).Value = omikuzi(result)
    
End Sub

Function getMaxRow(sheetName As String, row As String)

    getMaxRow = Worksheets(sheetName).Range(row & "65536").End(xlUp).row

End Function