私はある日、お客さんから「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 を返します。

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

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

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

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

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

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

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

操作方法

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

ゲームの開始と終了

テトリスを開始するときは「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 Vba の関数（プロシージャ）として簡単にまとめましたので記述します。

この処理はかなり簡単な関数（プロシージャ）としてまとめてます。

こんな感じですごく簡単な処理になっています。

またこの処理はコピーすればすぐに実装できるようにしています。

ですので、よければ必要な方はぜひコピペして使ってください。

Excel の表の最終行番号を取得する処理について

Excel の表の最終行番号を取得する方法は２通りあります。

「は？どういうこと？？」と思われた方もいるかもしれません。

これがどういうことなのかわかりやすく説明します。

セルの元々の位置から空白セルの位置まで下って移動

まずは最終行取得のために「セルの元々の位置から空白セルの位置まで下って移動」する方法についてです。

まずはこんな感じの１~５まで含まれる１列の表があるとします。

ここの一番上のセル番号（B2）を選択します。

そしてキーボードの「↓」キーを入力すれば表の一番下のセルに移動できます。

いわばこの処理を Excel VBAで実現すればOKっていうことです。

実際の Excel Vba での最終行のセル番号を取得する処理は下記になります。

Sub test()

    Debug.Print getLastRow("B2")
    
End Sub

Function getLastRow(nowCell As String)
    
    getLastRow = Range(nowCell).End(xlDown).row

End Function

上記は B2セル（表の一番上）から End(xlDown) と下っていくこと処理です。

今回はこの処理を getLastRow プロシージャとしてまとめました。

この関数（プロシージャ）の引数と戻り値は下記になります。

セルの一番下から空白セルの位置まで上って移動

次に「セルの一番下から空白セルの位置まで上って移動」する方法についてです。

先程と同じようにこんな感じの１~５まで含まれる１列の表があるとします。

これと同じ列の一番下のセルを選択します。

そしてキーボードの「↑」キーを入力すれば表の一番下のセルに移動できます。

この処理を Excel VBAで実現すればOKっていうことです。

実際の Excel Vba での最終行のセル番号を取得する処理は下記になります。

Sub test() 

　　　Debug.Print getLastRow2("B2") 

End Sub

Function getLastRow2(row As String)

    getMaxRow = Cells(Rows.Count, Range(nowCell).Column).End(xlUp).row

End Function

先程よりは少しややこしいです。

処理について順に説明します（例として B2セルの最終行を取得する場合を説明します）。

今回はこの処理を getLastRow2 プロシージャとしてまとめました。

この関数（プロシージャ）の引数と戻り値は下記になります。

二つの処理の違いについて

「これ結局何が違うの？」ってなると思います。

これらの違いは Excel の行の中に空白があるかどうかであり、

空白があると最終行の値が変わってきます。

例えば表の上から列番号を確認するとExcelの処理では空白セル直前のセル行番号になりますが、一番下から確認すると一番下のセル行番号になります。

これらのように違いがあるため、使い分けする必要があります。

Excel の表の最終列番号を取得する処理について

次にExcel の表の最終列番号を取得する方法は２通りあります。

これは前章で説明した「最終行番号取得のノウハウ」と特に変わりありません。

こちらも「は？どういうこと？？」と思われた方もいるかもしれません。

これがどういうことなのかわかりやすく説明します。

セルの元々の位置から空白セルの位置まで右に移動して移動

まずは「セルの元々の位置から空白セルの位置まで右に移動して移動」について説明します。

こんな感じの１~５まで含まれる１行の表があるとします。

ここの一番左のセル番号（B2）を選択します。

そしてキーボードの「→」キーを入力すれば表の一番右のセルに移動できます。

この処理を Excel VBAで実現すればOKっていうことです。

実際の Excel Vba での最終列のセル番号を取得する処理は下記になります。

Sub test() 

    Debug.Print getLastCol("B2") 

End Sub

Function getLastCol(nowCell As String)

    getMaxCol = Range(nowCell).End(xlToRight).Column

End Function

上記は B2セル（表の一番左）から End(xlToRight) と右にいくこと処理です。

今回はこの処理を getLastCol プロシージャとしてまとめました。

この関数（プロシージャ）の引数と戻り値は下記になります。

セルの一番右から空白セルの位置まで右に移動

まずは「セルの一番右から空白セルの位置まで右に移動」について説明します。

まずはこんな感じの１~５まで含まれる１行の表があるとします。

ここで B列の最終行を選択します。

そしてキーボードの「←」キーを入力すれば表の一番右のセルに移動できます。

この処理を Excel VBAで実現すればOKっていうことです。

実際の Excel Vba での最終列のセル番号を取得する処理は下記になります。

最終行のセル番号は下記になります。

Sub test() 

    Debug.Print getLastCol2("B2") 

End Sub

Function getLastCol2(nowCell As String)

    getLastCol2 = Cells(Range(nowCell).row, Columns.Count).End(xlToLeft).Column

End Function

処理について順に説明します（例として B2セルの最終列を取得する場合を説明します）。

この関数（プロシージャ）の引数と戻り値は下記になります。

二つの処理の違いについて

「これ結局何が違うの？」ってなると思います。

これらの違いは Excel の列の中に空白があるかどうかであり、

空白があると最終列の値が変わってきます。

例えば表の上から列番号を確認するとExcelの処理では空白セル直前のセル行番号になりますが、一番下から確認すると一番左のセル行番号になります。

これらのように違いがあるため、使い分けする必要があります。

最後に

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

今回はこんなことを紹介しました！

この記事が開発のお役に立てれば幸いです。

ではでは。

「Excel（エクセル）」というソフトはご存じだと思いますが、

「Excel マクロ（VBA）」はご存じでしょうか？

いまは社会の大半の業務資料は Excel で作成されたものばかり。

そんな資料には 「Excel マクロ」が必ず含まれています。

私はシステムエンジニアですが、業務上でそのような資料を扱うことがものすごく多いです。

「Excel なんてどうでもいいやろ～」

そう思われている人ほどぜひこの記事を読んでいただきたいです。

私の経験ですが「Excel」ができる人は、人の10倍仕事がはやくできます。

私の知っている優秀なエンジニアであり上司の人は、全員達人レベルで「Excel」ができていました。

凄い人は Excel で 1か月のカレンダーを５秒から 10 秒くらいで作っていました。

すべての業務（雑務）を Excel 化して自動化している人までいました。

私はそういう優秀な人たちの背中をみて「いつかこんなエンジニアになりたい！」と思い、

独学で Excel を勉強しました。

この記事では、そんな私が「Excel マクロ（VBA）」の魅力をたっぷりご紹介します！

Excel マクロとは？

Excel マクロとは、VBA （Visual Basic dor Application）と呼ばれるプログラミング言語で記述された

「Excelでの操作を自動化で実行できる」機能のことです。

Excel マクロを使えるようにするためには VBA を自由自在に使いこなせるようになる必要があります。

つまり「Excelマクロ を学ぶ」ことは、「VBA を学ぶ」ことと同義と考えていただいて問題ありません。

VBA を学ぶことのメリット

VBA を学ぶことのメリットについて解説します。

Office ソフトでの作業が全て自動化できる

マイクロソフト製の Office ソフト（Excel、Word、Power Point、Outlook）にはこのマクロ機能が搭載されています。

社会人での資料のほとんどが（私の会社では全てが）が Office ソフトで作成します。

それら全てにマクロ機能が搭載されています。

つまりVBA を学べば Office ソフト上での作業がすべて自動化できます。

そのため作業効率が飛躍的に向上します。

管理人も雑務はすべて Excel マクロをつかっており、雑務時間が大幅に短縮できました。

どれくらい早くなったかExcel マクロを使う前と使った後で比較したところ、

同じ作業でなんと４倍早く終わるようになりました。

学習コストが低く、すぐに書けるようになる

一般的なプログラミング言語の難易度は、記述するプログラミング言語が人間により理解しやすいものかどうかで決定します。

人間に理解しやすいプログラミング言語を高級言語、理解しにくいものを低級言語といいます。

一般的に VBA は高級言語に属するプログラミング言語です。

つまり Excel マクロ（VBA）はそんなに書いていて難しくない（理解しやすい）プログラミング言語なんです。

私は過去にさまざまプログラミング言語（C 、C++、Java、Pythonなど）を勉強してきました。

その中で一番簡単だったのが Excel VBA でした。

つまり、プログラミング言語を初めて書く勉強する人にも学習コストが低く

すぐに書けるようになるプログラミング言語です。

キャリアアップにつながる

エンジニアでよく見るのが「Excel マクロは知っているが、やり方がよくわからない」という人です。

プログラミングをしたことがない人は、最初のうちは VBA の書き方を覚えるのに少し時間がかかると思います。

そういった壁を感じてしまいやらない人が結構多く、そのため VBA の書き方を知らない人が多いのです。

そのため Excel マクロの 仕組みさえ理解して VBA を自由自在に書けるようになれば、

お仕事の依頼がめちゃくちゃもらえます。

私は職場では VBA を書ける数少ないプログラマーなので、

よく「こういうことしたいんやけど、 Excel マクロで作ってくれへん？」という依頼をもらいます。

そういった依頼をこなしていると、「こいつはできるやつ」と上司に評価されるようになります。

そうなることで最終的に、キャリアアップにもつながります。

フリーランスとしても生きていける

フリーランスとは、会社に所属せず個人で自由に仕事を契約する人のことです。

会社に所属しないため、職場でのめんどくさい人間関係や朝の決まった出勤などがいっさいなく自由に働くことができます。

SE（システムエンジニア）が一番あこがれる職業といっても過言ではありません。

その自由に憧れたせいか、よく知り合いの SE は仕事をやめてフリーランスになる人が多いです。

Excel VBA フリーランスの単価は、一般的には40万から70万です（多いところは200万というのも見かけました）。

案件も多く VBA を勉強することは、フリーランスとして一生食べていけます。

※ ネットで「Excel VBA フリーランス」で検索してみてください。様々な案件がヒットすると思います。

VBA で作成した作業自動化の具体的例

私は VBA で以下の作業を自動化しています。

これはほんの一部ですが、仕事では 100 近くのマクロを作成し作業を自動化しています。

これのいいところは一度作成する手間をかけると、あとはコーヒーを飲んでいるうちに作業が終わります。

他にもこのサイトでは Excel マクロで作成した様々なツールがあります。

ぜひそちらも参考にしてみてください。

※ Excel で ゲームも作成可能です。よければ以下の記事も参考にしてみてください♪

エクセルで遊べるテトリスの作り方【Vba ゲーム】

2019.2.20

エクセルでテトリスを作りました！！ 前からつくってみたいなあと思っていたゲームの一つで、これもなかなか時間がかかりました。 仕事終わってからだらだら作っていたら一週間くらいかかりました（工数はだいたい１人日～２人日くらい）。 ですが、思ったより簡単に作れました。エクセルで過去にオセロや将棋などつ...

最後に

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

私も最初のうちは「Excel って表つくるやつやろ？」と思っていました。

しかしExcel VBA を学ぶことで、Excel は Windows 上の作業を何でもできる最高のソフトという考えになりました。

ぜひ皆さんも Excel VBA を勉強してみてください。

最後までご精読いただきありがとうございます。