これはこのブログが100記事記念ということですごいものを作ってみたい！と思って作っていました。

（ 作り終わった後にいろいろと調べてみると、Excel ピアノって世の中に出回ってるとしてすこしがっかりしましたが、、、）

興味があればぜひどうぞ！

Excel ピアノの作り方は下記二つです。

これらを順に説明します。

ピアノ用のExcelシートを準備

まずExcel シートを下記の画像のように準備します。

これは実際にこのページからダウンロードできる Excel を見たほうが速いと思うので、説明は簡略化します。

しかし注意点はこのシートには非表示列（上記画像の赤枠の箇所）がある点です。

Excel Vba で ピアノを実装する

今回 Excel ピアノを実装する上で下記のような3つのプロシージャ（関数）を用意しました。

これはいまは意味がわからなくても大丈夫です。

(　´_ゝ｀)ﾌｰﾝって感じでさらーっと流してもらえればと思います。

selectCol プロシージャ・・・いま読み込んでいる列を表示させる処理

いま読み込んでいる列を表示させる処理というのは

下記のように列が順番に選択されてくる処理を意味します。

これは3列から順に列を選択していくだけのすごく簡単な処理です。

たとえば Columns("C:C").Select とすると C列が選択されます。

それをC,D,E .... と順にずらしていくということです。

myBeepプロシージャ・・・ BeepAPI で音を出す

今回ピアノの「ドレミファソラシド」を鳴らすために BeepAPI というAPI を用いりました。

このAPIではパソコンのBeep音（パソコンのピーとかブーってなる音）を鳴らすことができます。

BeepAPIを用いるには、はじめに下記のようなおまじないを書く必要があります（意味はわからなくても動きます）。

Declare Function BeepAPI Lib "kernel32.dll" Alias "Beep" _
(ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

注意点ですが、これをつかうときは「標準プロシージャ」でプログラムを実装する必要があります。

そして実際にBeepAPI から「ドレミファソラシド」を出すには周波数と鳴らす時間間隔（今回は200と設定）の設定が必要です。

なおBeepAPI で「ドレミ」を使う上で下記の周波数表を使いました。

※ 周波数についてはドレミファ音階のHz対応表を参考にしました。

たとえば「ド」を鳴らそうとします。

その場合は BeepAPI(262, 200)のように呼び出してやればOKってことです！

pianoプロシージャ・・・Excel ピアノのメインの処理

piano プロシージャとは前章で説明しました、下記処理をまとめて実行する処理（いわばメイン処理）です。

まとめただけなので、特に説明することもないので割愛します。。

Excel ピアノのソースコード

プログラミングのソースコードは下記になります。

Declare Function BeepAPI Lib "kernel32.dll" Alias "Beep" _
(ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Const TIME_INTERVAL = 200
Const CELL_START_COL = 4

Const CELL_CHECK_ROW = 3
Const CELL_VOICE_ROW = 4
Const CELL_START_ROW = 5

Sub piano()
    
    Dim i
    Dim voice, voiceRow
    
    i = CELL_START_COL
    
    While Cells(CELL_CHECK_ROW, i) < 10 And Cells(CELL_CHECK_ROW, i) <> ""
        
        Call selectCol(i)

        voiceRow = Cells(CELL_VOICE_ROW, i).Value + CELL_VOICE_ROW
        
        If voiceRow <> 0 And voiceRow <> "" Then
            voice = Cells(voiceRow, 1).Value
            Call myBeep(voice)
        Else
            Sleep TIME_INTERVAL
        End If
        i = i + 1
        
    Wend
    
End Sub

Private Sub selectCol(i)


    buf = Cells(1, i).Address(True, False)
    buf = Left(buf, InStr(buf, "$") - 1)
    Columns(buf & ":" & buf).Select
    
End Sub

Private Sub myBeep(voice)

    Call BeepAPI(voice, TIME_INTERVAL)

End Sub

私はある日、お客さんから「100ファイル近くのExcelファイルのファイル名を手作業で変更してくれ～」っていう依頼がありました。

具体的には「ファイル名_v1.2.xlsx」→「ファイル名_v1.3.xlsx」にしてくれ～～っていう内容です。

もちろん、ファイル数が少ないなら手でやったほうが速いと思いますが、

毎回、100ファイル近くを手作業でやるのにどれだけ時間がかかるか・・

しかし仕事をしていれば、少なからずそんなめんどくさい作業をすることがあると思います。

そこでこの度はExcel をつかってボタン一つでファイル名を一括置換するツールを作りました！

このツールは Excel Vba というプログラミングで作成されています。

この記事では「Excelでできる複数のファイル名を一括置換するツール」の使い方と作り方をご紹介します！

この「Excelでできる複数のファイル名を一括置換するツール」では以下の用に使います。

「検索ボタン」を押下してリネームしたいファイル一覧を取得

まず「検索ボタン」を押下します。

すると下記のようなダイアログが表示されるので、ファイル名を変換したいファイルが配架されているフォルダを選択します。

このときファイル名が表示されませんが、問題ありません。

これにてB列とＣ列にファイル名とフォルダ名がそれぞれ出力されます。

ファイル名、フォルダ名を手入力しても問題ないですが、入力し間違えないようにする必要があります。

ファイル名（置換後）列にファイル名を入力

ファイル名（置換後）列にファイル名を入力します。

このツールではファイル名（置換前）→ファイル名（置換後）のようにファイルがリネーム（名前が変更）されます。

ファイル名（置換後）列に入力後、チェック列（E列）の値がOKになっていれば問題なしです。

なおチェック列がOK以外の値の場合はファイル名置換処理が実行されません。

チェック列がＯK以外のケース

チェック列では入力した値に誤りがあるかどうかをチェックします。

もし上記項目を満たした場合、下記画面のようにエラーメッセージが表示されるようになっています。

※ なおこのエラーメッセージはH列（非表示列）に入力していますので、H列は消さないようにお願いします！

「一括置換」ボタンでファイル名が変更

最後に「一括置換」ボタンを押下します。

すると下記のような処理完了メッセージが表示されます。

フォルダを確認しに行くとファイル名が一括置換されていることが確認できます！

以上がこのツールの使い方です。

続いてはこのツールの使い方を説明します。

このコードを Excel の開発タブ→ Visual Basic で表示されるエディタに貼り付ければOKです。

※ 開発タブがない場合は下記ページを参考にしてください。

３分でできる！Excel VBA の開発を行うために必要な事前準備

2018.11.14

いまから 「vba を始めたいけれど、Excel で何をどうやってすればいいかわからない」という悩みはありませんか？ 本ページでは vba をどうやってはじめるか３分以内に終わる方法を解説します。 v...

'=================================================================================
' 複数ファイル名を一括置換マクロ
'=================================================================================

Const SEARCH_WORD = "\*.*"

Const CELL_PRINT_COL = 2
Const CELL_PRINT_ROW = 2
Const CELL_SEARCH_WORD = "B3"


' ファイル一覧取得
Sub getFileList()

    Application.ScreenUpdating = False

    Dim folderName
    Dim lastRow
    
    folderName = getFolderName()
    fileList = Dir(folderName & SEARCH_WORD)
    
    ' 最終行取得
    If Cells(CELL_PRINT_ROW + 1, CELL_PRINT_COL) = "" Then
        lastRow = CELL_PRINT_ROW + 1
    Else
        lastRow = Cells(CELL_PRINT_ROW, CELL_PRINT_COL).End(xlDown).Row
    End If
    
    Do While fileList <> ""
                
        Cells(lastRow, CELL_PRINT_COL) = folderName
        Cells(lastRow, CELL_PRINT_COL + 1) = fileList
        lastRow = lastRow + 1
        fileList = Dir()
        
    Loop
    
    Application.ScreenUpdating = True
    
End Sub


' ファイル名を一括置換
Sub replaceFile()

    Application.ScreenUpdating = False

    Dim folderName
    Dim beforeFile
    Dim afterFile
    Dim i
    
    On Error Resume Next
    i = CELL_PRINT_ROW + 1
    
    While Cells(i, CELL_PRINT_COL) <> ""
    
        folderName = Cells(i, CELL_PRINT_COL)
        beforeFile = folderName & "\" & Cells(i, CELL_PRINT_COL + 1)
        afterFile = folderName & "\" & Cells(i, CELL_PRINT_COL + 2)
        
        If check(beforeFile, afterFile) And Cells(i, CELL_PRINT_COL + 3) = "OK" Then
            Name beforeFile As afterFile
            Cells(i, CELL_PRINT_COL + 4) = "OK"
        Else
            Cells(i, CELL_PRINT_COL + 4) = "NG"
        End If
    
        i = i + 1
    
    Wend
    
    Application.ScreenUpdating = True
    
    MsgBox "ファイル名を一括置換しました！"
    
End Sub

' 初期化
Sub reset()

    Application.ScreenUpdating = False
    
    Range(Cells(CELL_PRINT_ROW + 1, CELL_PRINT_COL), Cells(Rows.Count, CELL_PRINT_COL + 2)).ClearContents
    Range(Cells(CELL_PRINT_ROW + 1, CELL_PRINT_COL + 4), Cells(Rows.Count, CELL_PRINT_COL + 4)).ClearContents
     
    Application.ScreenUpdating = True

End Sub


' 入力精査
Private Function check(ByVal beforeFile, ByVal afterFile) As Boolean

    If Dir(beforeFile) <> "" And Dir(afterFile) = "" Then
        check = True
    Else
        check = False
    End If
    
End Function


' ダイアログでフォルダ名取得
Private Function getFolderName()

    Dim folderPath As Variant
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = 0 Then
            End
        End If
        folderPath = .SelectedItems(1)
    End With
    
    getFolderName = folderPath
  
End Function

今回のツールでの「（リネームする）ファイル一覧を取得」と「ファイル名を一括置換」する方法について説明します。

※ reset（）については割愛します。

Excel で（リネームする）ファイル一覧を取得・・・getFileList()

ファイル一覧を取得する方法は下記になります。

フォルダ名取得用のダイアログ画面は Application.FileDialog(msoFileDialogFolderPicker)で取得します。

戻り値として選択したフォルダ名（フルパス）で取得できます。

その取得したフォルダ名から Dir 関数でファイル一覧を取得し、シートに出力するだけです。

' ファイル一覧取得
Sub getFileList()

    Application.ScreenUpdating = False

    Dim folderName
    Dim lastRow
    
    folderName = getFolderName()
    fileList = Dir(folderName & SEARCH_WORD)
    
    ' 最終行取得
    If Cells(CELL_PRINT_ROW + 1, CELL_PRINT_COL) = "" Then
        lastRow = CELL_PRINT_ROW + 1
    Else
        lastRow = Cells(CELL_PRINT_ROW, CELL_PRINT_COL).End(xlDown).Row
    End If
    
    Do While fileList <> ""
                
        Cells(lastRow, CELL_PRINT_COL) = folderName
        Cells(lastRow, CELL_PRINT_COL + 1) = fileList
        lastRow = lastRow + 1
        fileList = Dir()
        
    Loop
    
    Application.ScreenUpdating = True
    
End Sub

' ダイアログでフォルダ名取得
Private Function getFolderName()

    Dim folderPath As Variant
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = 0 Then
            End
        End If
        folderPath = .SelectedItems(1)
    End With
    
    getFolderName = folderPath
  
End Function

Excel でファイル名を一括置換・・・replaceFile()

シートに記述されている置換前後のファイル名を取得し、それらを Name 関数で取得します。

このリネーム（ファイル名を変更する）処理は一行ずつ実行されます。

このファイル名変更処理をシートの表の（B列）に値が実行されるまで実行します。

' ファイル名を一括置換
Sub replaceFile()

    Application.ScreenUpdating = False

    Dim folderName
    Dim beforeFile
    Dim afterFile
    Dim i
    
    On Error Resume Next
    i = CELL_PRINT_ROW + 1
    
    While Cells(i, CELL_PRINT_COL) <> ""
    
        folderName = Cells(i, CELL_PRINT_COL)
        beforeFile = folderName & "\" & Cells(i, CELL_PRINT_COL + 1)
        afterFile = folderName & "\" & Cells(i, CELL_PRINT_COL + 2)
        
        If check(beforeFile, afterFile) And Cells(i, CELL_PRINT_COL + 3) = "OK" Then
            Name beforeFile As afterFile
            Cells(i, CELL_PRINT_COL + 4) = "OK"
        Else
            Cells(i, CELL_PRINT_COL + 4) = "NG"
        End If
    
        i = i + 1
    
    Wend
    
    Application.ScreenUpdating = True
    
    MsgBox "ファイル名を一括置換しました！"
    
End Sub

' 入力精査
Private Function check(ByVal beforeFile, ByVal afterFile) As Boolean

    If Dir(beforeFile) <> "" And Dir(afterFile) = "" Then
        check = True
    Else
        check = False
    End If
    
End Function

また上記処理では入力したファイル名が正しいかどうかを精査する check 関数も実行しております。

この check関数は下記条件すべてを満たす場合に True、それ以外は False を返します。

このツールさえあればどれだけファイル数が多くてもファイル名の一括置換がラクラクできます！

このデジタル時計は 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です。

わたしはすごい適当な性格なので、このへんよく忘れてしまいます。新人のときは良く怒られました。。。

最初は手で直していたんですが、そのうちめんどくさくなってマクロ化しました！！！

今回はそのマクロを作る方法について超簡単にご紹介します！！

マクロの作り方

マクロの作り方は超簡単です。

「開発タブ」→ 「Visual Studio」からエディタを開きます。

※ 開発タブが表示されていない場合は「ファイル」→「オプション」→「リボンのユーザ設定」で開発をチェックいれればOKです！

それで下記を貼り付けます。

Sub シートを整える()

    Dim ws As Worksheet
    Dim firstWs As Worksheet
    Dim firstFlag
    On Error Resume Next
    
　　Application.ScreenUpdating = False

    firstFlag = False
    
    For Each s In Worksheets
        
        Dim nowSheet As Worksheet
        Set nowSheet = Worksheets(s.Name)
        
        ' 最初のシート情報を控えておく
        If firstFlag = False Then
            
            Set firstWs = nowSheet
            firstFlag = True
            
        End If
        
        nowSheet.Activate
        
        ' 横スクロールを一番左
        ActiveWindow.ScrollColumn = 1
        
        ' 縦スクロールを一番上
        ActiveWindow.ScrollRow = 1
        
        ' 拡大率100%
        ActiveWindow.Zoom = 100
        
        ' A1セルを選択
        nowSheet.Range("A1").Select
        
    Next
    
    ' 最初のシートを選択
    firstWs.Select

　　Application.ScreenUpdating = True
    
End Sub

貼ったら Excel を保存します。

注意点ですが、ファイル拡張子を「xlam」にします（これがのちのち役立ってきます！！）。

ファイル名はなんでもOKです。

これでOKです。

すると保存したのに「.xlam」ファイルが表示されねえーーーってなりませんか？

「.xlam」ファイルはExcelの仕様で表示されません（なんでかは知りません。。）。

ですが、裏では開かれていることになっています。

この状態でExcel の左上の矢印を押下して「その他のコマンド」をクリックします。

それで下記のような画面が出るので、

コマンドの選択欄を「マクロ」にして→ さっき作ったマクロ「シートを整える」を追加→OKボタンを押下します。

あとは以下のようにボタンが表示されればOKです。

これでどんなExcelブックを開いてもいつでも「A1セル選択、拡大率100%、スクロールを一番左上」ができます！！

このマクロについて

このマクロがどういう風に動いているかザックリ説明します。

最後に一番前のシートにもどりますが、一番前のシートが非表示の場合は戻らないのでご注意ください。

最後に

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

これのマクロさえあれば、Excelファイルの提出前のめんどくさい作業もなくなると思います。

ではでは。

どーも 暇人プログラマー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 でやりたくて仕方ない方がいましたら、

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

Excel でカウントディレクトリのファイルに加えてサブディレクトリに含まれるファイルの一覧を出力するマクロの作成方法についてご紹介します。

ちょっと専門用語が多かったような気もするので、

要するにあるフォルダ内にフォルダの中のファイルも全部含めてファイル一覧させる方法についてご紹介します。

今回は Excel Vba を使います。

自分でつくってみてだいたい１～２時間くらいでできましたが、結構簡単なのでぜひ興味のある方は参考にしてみてください。

※実際に作成したマクロは下記からダウンロードできますので、興味のある方はぜひダウンロードしてみてください。

作成方法

ご紹介します Excel マクロは大きく二つの機能から構成されています。

ファイル一覧を出力するパスを取得

ファイル一覧を表示させるためのファイルパスを取得するための機能をご紹介します。

下記画面のように「フォルダパス取得」ボタンを押下することで、ファイル一覧を表示させるためのファイルパス（下画面なら「C:\test」)を表示させます。

下記にソースコードを記載します。

Option Explicit

Const X As Integer = 1
Const Y As Integer = 8
Const CELL_FILE_PATH As String = "B3"

Const ERRORMESSAGE As String = "フォルダ一覧を出力するための正しいパスを入力ください。"
Const COMPLETEMSG As String = "処理が完了しました。"

' ファイルパス取得
Sub getFilePath()

     With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            Range(CELL_FILE_PATH).Value = .SelectedItems(1)
        End If
    End With
    
End Sub

' メイン
Sub getFileList()

    Dim start_x As Long: start_x = X
    Dim start_y As Long: start_y = Y
    Dim searchFolderPath As String
    Dim checkFolderPath
    
    Application.ScreenUpdating = False
    On Error Resume Next
    
    searchFolderPath = Range(CELL_FILE_PATH).Value
    
    ' ファイルの存在チェック
    checkFolderPath = Dir(searchFolderPath, vbDirectory)
    
    If searchFolderPath = "" Or checkFolderPath = "" Then
        MsgBox ERRORMESSAGE, vbCritical
        End
    End If

    ' シートの初期化
    Call settingSheet
    
    '　ファイル一覧作成
    Call printFileList(searchFolderPath, start_x, start_y)

    ' フォーマット整形
    Call formattingSheet

    MsgBox COMPLETEMSG, vbInformation

    Application.ScreenUpdating = True

End Sub

' ファイル一覧作成
Private Sub printFileList(searchFolderPath As String, ByRef start_x, ByRef start_y)
    
    Dim fso As New FileSystemObject
    Dim folderList As Folders
    Dim folderName As folder
    Dim fileName As File
    
    Dim str As String
    Dim slashNum As Long
    
    Set folderList = fso.GetFolder(searchFolderPath).SubFolders
    
    'フォルダ内のファイル名の取得し、セルにパスとファイル名を書き込む
    For Each fileName In fso.GetFolder(searchFolderPath).Files
        
        slashNum = InStrRev(fileName.Path, "\")
        Cells(start_y, start_x).Value = Mid(fileName.Path, slashNum + 1)
        Cells(start_y, start_x + 1).Value = Left(fileName.Path, slashNum - 1)
        Cells(start_y, start_x + 2).Value = Format(fileName.Size / 1024, "0.#0000") & " バイト"
        Cells(start_y, start_x + 3).Value = fileName.DateCreated
        Cells(start_y, start_x + 4).Value = fileName.DateLastModified
        start_y = start_y + 1
    
    Next
    
    ' サブフォルダ一覧取得　再帰処理
    For Each folderName In folderList
        Call printFileList(folderName.Path, start_x, start_y)
    Next
    
End Sub

' シートの初期化
Private Sub settingSheet()

    Dim maxCol
    Dim maxRow

    maxRow = Cells(Rows.Count, X).End(xlUp).Row
    maxCol = Cells(Y, Columns.Count).End(xlToLeft).Column
    Range(Cells(Y, X), Cells(maxRow + Y, maxCol + X)).ClearContents

End Sub

' フォーマット整形
Private Sub formattingSheet()

    Columns("A:E").Select
    Columns("A:E").EntireColumn.AutoFit
    Range("A1").Select

End Sub

要はダイアログ画面からファイルをファイルパスを選択して、選択した値をB3セルに書き込むというそれだけの処理です。

取得したパスからファイル一覧を出力

これは「ファイル一覧出力」ボタンを押下することで、取得したパスのファイル一覧出力を出力させる処理です。

処理は下記の順番になります。順を追って説明していきます。

取得したパスが正しい値であるかを確認

Const ERRORMESSAGE As String = "フォルダ一覧を出力するための正しいパスを入力ください。"
    Dim searchFolderPath As String
    Dim checkFolderPath

    searchFolderPath = Worksheets(FOLDERPATH).Range("B3").Value
    
    ' ファイルの存在チェック
    checkFolderPath = Dir(searchFolderPath, vbDirectory)
    
    If searchFolderPath = "" Or checkFolderPath = "" Then
        MsgBox ERRORMESSAGE, vbCritical
        End
    End If

シートの初期化

これは処理を行う前にシートをきれいにする処理のことです。

具体的には、ファイル一覧を出力しているセル範囲（B6以降のセル）の値のみを削除しています（書式は削除していません）。

ソースコード

Const X As Integer = 2
    Const Y As Integer = 6

    Dim start_x As Long: start_x = X
    Dim start_y As Long: start_y = Y    

    ' シートの初期化
    maxRow = Worksheets(FOLDERPATH).Cells(Rows.Count, X).End(xlUp).Row
    maxCol = Worksheets(FOLDERPATH).Cells(Y, Columns.Count).End(xlToLeft).Column
    Worksheets(FOLDERPATH).Range(Cells(Y, X), Cells(maxRow + Y, maxCol + X)).ClearContents

ファイル一覧作成

ここではファイル一覧を取得し、それをシートに出力する処理です。

引数は、取得したパス searchFolderPath、書き込むセルの位置 start_x、 start_y の３つです。

まずはフォルダ以外のファイル名を取得し、そのファイルの情報（下記に記載します）を取得します。

下記の 変数 fileNameはフォルダ内にあるファイルを変数に格納させた値と思ってください。

※ ファイル名の処理

まず、フォルダ内のファイルのフルパス fileName.Path とし、その fileName.Pathの後方から最初に来る「\」よりも後ろの値を取得します。

何言っているかよくわからない方もいると思いますので、もう少し具体的に説明しますと

例えばフォルダ内のファイルのフルパス fileName.Pathが以下のような値としますと、

slashNum = InStrRev(fileName.Path, "\")
        'セルにパスとファイル名を書き込む
        Worksheets(FOLDERPATH).Cells(start_y, start_x).Value = Mid(fileName.Path, slashNum + 1)

次にフォルダ内にあるサブフォルダ（サブディレクトリ）については、GetFolder関数を用いて取得します。

そして再帰処理（つまり処理を繰り返す）を行い、サブフォルダが見つからなくなくなるまで処理をくり返します。

その処理を繰り返している間も、そのフォルダに含まれるファイル名はすべて出力するようにします。

下記にソースコードを記載します。

' ファイル一覧作成
Private Sub printFileList(searchFolderPath As String, ByRef start_x, ByRef start_y)
    
    Dim fso As New FileSystemObject
    Dim folderList As Folders
    Dim folderName As folder
    Dim fileName As File
    
    Dim str As String
    Dim slashNum As Long
    
    Set folderList = fso.GetFolder(searchFolderPath).SubFolders
    
    'フォルダ内のファイル名の取得
    For Each fileName In fso.GetFolder(searchFolderPath).Files
        slashNum = InStrRev(fileName.Path, "\")
        'セルにパスとファイル名を書き込む
        Worksheets(FOLDERPATH).Cells(start_y, start_x).Value = Mid(fileName.Path, slashNum + 1)
        Worksheets(FOLDERPATH).Cells(start_y, start_x + 1).Value = Left(fileName.Path, slashNum - 1)
        Worksheets(FOLDERPATH).Cells(start_y, start_x + 2).Value = Format(fileName.Size / 1024, "0.#0") & " バイト"
        Worksheets(FOLDERPATH).Cells(start_y, start_x + 3).Value = fileName.DateCreated
        Worksheets(FOLDERPATH).Cells(start_y, start_x + 4).Value = fileName.DateLastModified
        start_y = start_y + 1
    Next
    
    ' サブフォルダ一覧取得　再帰処理
    For Each folderName In folderList
        Call printFileList(folderName.Path, start_x, start_y)
    Next
    
End Sub

最後に

いかがでしょうか？

もしつくるのめんどくせえとか実際に作ったのがそんなのか見てみたい！という人がいましたら下記ボタンからダウンロードできますので、ぜひ試してみてください。

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

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

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

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

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

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

操作方法

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

ゲームの開始と終了

テトリスを開始するときは「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 マクロの作り方についてご紹介します。

このマクロは席数を自分で指定できるようにしてあるので、例えば 4 × 4 や ５× 6 の席でも自由に変えて席替えできることができます。

小学校や中学、高校では、気分転換のためかなんとなくか目的はさまざまですが、とにかく定期的に席替えが行われると思います。

そんなとき毎回くじ作ってそのくじを引いてみんなでギャーギャー騒いで...って楽しいんですが、教員の方は早く帰りたいのかもしれません。

そんな教師はあんまり見たことがないんですが、少なからず席替えに時間を割くことがほとんどなくなりますので「いいな」と思われた人はぜひ使ってみてください。

※実際に作成した Excel マクロは下記のボタンからダウンロードできます。

操作方法

（１）名前を入力します。名前の左に番号が付いていますが、番号はなんでもいいです。

ダウンロードしたマクロには番号を自動で入力する関数を埋め込んでいますが、消して出席番号とかにしていただいても問題ありません。

（２）席の行数と列数を入力します。値は整数を入力してください。また「チェック」というセルで入力チェックを行ってます。

例えば、名簿シートに１０人で座席数が６（行数 : 2  列数 : 3）の場合は、４人分席が不足していますね。こういうときは「チェック」欄に座席数が不足しています。というメッセージが表示されます。

（３）「座席表を作成」ボタンを押下します。すると別シート「座席表」に結果が表示されます。

座席表自動作成マクロの作り方

座席表自動生成マクロの作成方法についてご紹介します。今回は Excel vba をつかって作成しています。

シートは上記２種類から構成されます。要は入力用シートとして「名簿」、出力用シートとして「座席表」の２種類です。

「名簿」シート

入力欄は「名前」「行数」「列数」の三つです。

「番号」はいちおうつけていますが、処理上は何の関係もありません。つまりどんな番号が入力されても問題なく動作できます。

ダウンロード用の Excel マクロは自動で入力できるようにしていますが、上書きして出席番号にしていただいても何の問題ありません。

「座席表」シート

初期はまっさらなシートです。処理が完了した後に座席表が書き出されます。

処理内容（Excel vba）

名簿シートの読み込み

これはシンプルな処理で、「名簿」シートのB列２行目からセルの値が空白になるまで読み込んで配列に入力しているだけです。

'名簿シートの読み込み
Private Sub readNameList(ByRef NameList() As String)
    
    Const x As Integer = 2
    Const y As Integer = 3
    
    Dim Name As String
    Dim index As Integer: index = 0

    Do
        ReDim Preserve NameList(index)
        Name = Worksheets(NAMELISTSHEET).Cells(y + index, x).Value
        NameList(index) = Name
        index = index + 1
    Loop Until Name = ""
    
    If UBound(NameList) = 0 Then
        MsgBox "名前を入力してください"
        End
    End If
    
    ReDim Preserve NameList(UBound(NameList) - 1)

End Sub

座席表シートへの書き込み

「名簿」シートから取得した名前のデータを含む配列をランダムに取り出して、取り出した値を「座席表」シートに書き込むだけの処理です。

ソースコードを見ると複雑そうに見えますがやっていることはシンプルです。

' 座席シート表への書き込み
Private Sub writeZasekihyo(ByRef NameList() As String)

    Const x As Integer = 2
    Const y As Integer = 4
    Dim RandList() As Integer
    Dim Name As String
    Dim i, j, k
    j = 0
    k = 0
    
    Dim Max_Row
    Dim Max_Column
    
    Max_Row = Worksheets(NAMELISTSHEET).Cells(2, 4).Value
    Max_Column = Worksheets(NAMELISTSHEET).Cells(2, 5).Value
 
    If Max_Row = "" Or Max_Column = "" Then
        MsgBox "行と列を入力してください"
        End
    End If
    
    If Max_Row < 1 Or Max_Column < 1 _
        Or IsNumeric(Max_Row) = False Or IsNumeric(Max_Column) = False Then
        MsgBox "行と列には 1 以上の数値を入力してください"
        End
    End If
    
    
    ' 乱数作成
    Call calRandomArray(RandList, UBound(NameList) + 1)
    
    ' 初期化
    Application.ScreenUpdating = False
    
    Call defaultSetting(x, y - 2, Max_Row)
    
    ' 座席表へ書き込み
    For i = 0 To Max_Row * Max_Column - 1
        If i <= UBound(RandList) Then
            Name = NameList(RandList(i))
        Else
            Name = ""
        End If
        Call writeZasekihyo_oneChair(k + x, j + y, Name)
        If k = Max_Column - 1 Then
            k = 0
            j = j + 1
            If j = Max_Row Then
                Exit For
            End If
        Else
            k = k + 1
        End If
    Next i

    Application.ScreenUpdating = True
    
End Sub

' 乱数生成
Sub calRandomArray(ByRef arr() As Integer, ByVal MAX_NUM As Integer)

    Dim i, rand As Integer
    Dim num() As Boolean
    ReDim num(MAX_NUM)
    ReDim arr(MAX_NUM)
    
    Randomize
    For i = 0 To MAX_NUM - 1
        Do
        rand = Int(Rnd() * MAX_NUM)
        Loop Until num(rand) = False
        arr(i) = rand
        num(rand) = True
    Next i

    ReDim Preserve arr(UBound(arr) - 1)
    
End Sub

' 初期化
Private Sub defaultSetting(ByVal x As Integer, ByVal y As Integer, ByVal Max_Row As Integer)

    Worksheets(ZASEKISHEET).Select
    
    With Worksheets(ZASEKISHEET).Range(Cells(y, x), Cells(y + 100, x + Max_Row + 100))
        .ClearContents
        .Borders.LineStyle = xlLineStyleNone
    End With
    
    Worksheets(ZASEKISHEET).Rows("2:2").Select
    Selection.Delete Shift:=xlUp

    Worksheets(ZASEKISHEET).Range("A1").Select

End Sub

' 座席のセルの書式
Private Sub writeZasekihyo_oneChair(ByVal x As Integer, ByVal y As Integer, ByVal Name As String)
    
    With Worksheets(ZASEKISHEET).Cells(y, x)
        .Value = Name
        .Borders.LineStyle = xlContinuous
        .RowHeight = 50
        .ColumnWidth = 20
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Font.Size = 20
    End With
        
End Sub

教卓の書き込み

最後に教卓を書き込む処理です。２行目に固定で、列は座席表の列数の値に応じて書き込まれます。

席の列数を2で割ったときの剰余計算（余りを算出）をして、その値が1の場合（つまり奇数のとき）は、席の列数を２で割った値を整数に変換し、得られた値 + 2を書き込み先の列番号とします。

席の列数を剰余計算をした値が0の場合（つまり偶数のとき）、席の列数を２で割った値を整数に変換し、得られた値 + 1 と得られた値 + 2 を書き込み先の列番号（事前に二つのセルを結合させるように処理）とします。

例えば席の列数が７（奇数）の場合、7 ÷ 2 = 3.5 を整数にして 3にします。そして 3 + 2 = 5 列目のセルに書き込むようにします。

また席の列数が８（偶数）の場合、8 ÷ 2 = 4とし、4 + 1 = 5 列目と 4 + 2 = 6 列目を書き込み先の列番号とします。

最後の + 2 ですが、これはB列（つまりセルの２列目）から座席表を書き込むように処理するためにつけています。

' 教卓を描く
Private Sub writeKyotaku()

    Const x As Integer = 2
    Const y As Integer = 4
    Dim kyotaku As Integer
    Dim Max_Column As Integer
    
    Max_Column = Worksheets(NAMELISTSHEET).Cells(2, 5).Value
    kyotaku = Int(Max_Column / 2)
        
    If Int(Max_Column / 2) = 0 Then
        kyotaku = 0
        With Worksheets(ZASEKISHEET).Cells(2, kyotaku + x)
            .Value = "教卓"
            .Borders.LineStyle = xlContinuous
            .RowHeight = 50
            .ColumnWidth = 20
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Font.Size = 20
        End With
    Else
        If Max_Column Mod 2 = 1 Then
            kyotaku = Int(Max_Column / 2)
            With Worksheets(ZASEKISHEET).Cells(2, kyotaku + x)
                .Value = "教卓"
                .Borders.LineStyle = xlContinuous
                .RowHeight = 50
                .ColumnWidth = 20
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Font.Size = 20
            End With
        Else
            kyotaku = Int(Max_Column / 2) - 1
            With Worksheets(ZASEKISHEET).Range(Cells(2, kyotaku + x), Cells(2, kyotaku + x + 1))
                .Merge
                .Value = "教卓"
                .Borders.LineStyle = xlContinuous
                .RowHeight = 50
                .ColumnWidth = 20
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Font.Size = 20
            End With
        End If
    End If

    
End Sub

まとめ

いかがでしょうか？

かなりざっくりした説明だったかもしれませんので、もし作るのがめんどくさいと感じた方は下記ボタンからダウンロードしてみてください。

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」プロシージャの中身を好きなように編集することで、さまざまなプログラムを作成することができます。

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