Excelを使ったゲームのつくり方！Excelで動くテトリス～コピペで使えるExcelマクロ～
割引あり
Excelマクロ（Excel VBA）を使えば、単なる表計算ソフトとしてだけではなく、簡単なゲームやインタラクティブなアプリケーションを作成することができます。今回ご紹介するコードは、Excel上でテトリスの基本的な動作を再現するものです。
Excelマクロの基本的な使い方は、下の記事を参考にしてください
1. マクロの概要
このマクロは、Excelシート上にテトリスの盤面を描画し、以下のような動作を実現します。
テトリミノの定義
テトリミノ（I型、O型、T型、L型、J型、S型、Z型）の各形状は、クラスモジュール「CTetromino」で定義されています。各テトリミノは、4つのブロックの相対座標を持ち、回転処理もこのクラスで行われます。盤面管理
マクロ内では、盤面のサイズや描画開始位置、各セルの状態（空か、ブロックがあるか）を管理する定数と配列が定義されています。ゲームループと操作
StartGame マクロでゲームが初期化され、GameTick マクロが一定間隔で実行されることで、テトリミノの自動落下やラインクリア、ゲームオーバーの判定が行われます。また、矢印キーの入力でテトリミノを左右移動や回転、瞬間落下させることができる仕組みも組み込まれています。
画面イメージの紹介
追記：少しレイアウトを変更して、次のテトリミノが表示される仕様に変更しました。
動画はこちらから
2. コードの説明
クラスモジュール：CTetromino
メンバ変数 mCoords
各テトリミノの4ブロックの相対座標（行と列）を格納する配列です。Init メソッド
引数として渡された2次元配列（ブロックの座標情報）を使って、テトリミノの形状を初期化します。GetBlock 関数
指定したブロック番号に対して、回転（90度ずつ）と指定位置への移動を行い、最終的な絶対座標を返します。
回転処理は、座標を入れ替えながら符号を反転させることで実現しています。GetBlocks 関数
テトリミノの4ブロックすべてについて、上記の GetBlock を使い、まとめて座標情報を配列として返します。
' クラスモジュール: CTetromino
Option Explicit
Private mCoords() As Integer
' mCoords は各ブロックの相対座標（2次元配列: 行: 0～3, 列: 0～1）を保持します
' 初期化メソッド
Public Sub Init(ByVal arr As Variant)
Dim r As Integer, c As Integer
' arr は (0～3, 0～1) の2次元配列であると想定
ReDim mCoords(LBound(arr, 1) To UBound(arr, 1), LBound(arr, 2) To UBound(arr, 2))
For r = LBound(arr, 1) To UBound(arr, 1)
For c = LBound(arr, 2) To UBound(arr, 2)
mCoords(r, c) = arr(r, c)
Next c
Next r
End Sub
' 指定ブロック番号 index に対して、rotation 回（90度ずつ）の回転と、位置 (posX, posY) を加えた絶対座標を返す
Public Function GetBlock(ByVal index As Integer, ByVal rotation As Integer, ByVal posX As Integer, ByVal posY As Integer) As Variant
Dim bx As Integer, by As Integer, temp As Integer, i As Integer
bx = mCoords(index, 0)
by = mCoords(index, 1)
For i = 1 To rotation
temp = bx
bx = by
by = -temp
Next i
Dim result(0 To 1) As Integer
result(0) = posX + bx
result(1) = posY + by
GetBlock = result
End Function
' 4ブロックすべての座標を配列で返す
Public Function GetBlocks(ByVal rotation As Integer, ByVal posX As Integer, ByVal posY As Integer) As Variant
Dim blocks(0 To 3) As Variant
Dim i As Integer
For i = 0 To 3
blocks(i) = Me.GetBlock(i, rotation, posX, posY)
Next i
GetBlocks = blocks
End Function
標準モジュール（メインのコード）
定数とグローバル変数
盤面のサイズ（横幅、縦幅）や、シート上での描画開始位置が定義されています。また、固定ブロックの配置や各テトリミノのオブジェクト、色、現在操作中のテトリミノの状態などを管理する変数が用意されています。テトリミノの初期化 (InitTetrominoes サブプロシージャ)
7種類のテトリミノ（I型、O型、T型、L型、J型、S型、Z型）の形状を定義し、各オブジェクトに初期化しています。
ここでは、各形状に合わせた相対座標を配列に設定し、CTetromino クラスの Init メソッドで登録しています。ゲーム開始とループ (StartGame と GameTick)
StartGame は、盤面やテトリミノの初期化、キー割り当て（矢印キーのマクロ紐付け）、シートのクリア、最初のテトリミノ生成を行います。
GameTick は、一定時間ごとに実行され、テトリミノの落下、配置、ラインクリア、ゲームオーバーの判定を担当します。
キー入力イベントを利用して、ユーザーの操作に合わせた処理も随時呼び出されます。
ユーザー操作マクロ
MoveLeft、MoveRight、RotatePiece、DropPiece の各サブプロシージャは、ユーザーが矢印キーを押した際に呼び出され、テトリミノを左右に移動したり、回転、または一気に落下させる処理を行います。盤面描画 (DrawBoard)
Excelシート上に、固定されたブロックと現在落下中のテトリミノの両方を描画します。セルの色を変えることで、各ブロックの形状や位置が視覚的に分かるようになっています。
Option Explicit
'=== 定数 ===
Const BoardWidth As Integer = 10 ' 盤面の横幅（セル数）
Const BoardHeight As Integer = 20 ' 盤面の高さ（セル数）
Const BoardStartRow As Integer = 2 ' 盤面描画開始行（シート上）
Const BoardStartCol As Integer = 2 ' 盤面描画開始列（シート上）
' 次テトリミノ表示領域（盤面右側の例）
Const NextPieceStartRow As Integer = 2
Const NextPieceStartCol As Integer = BoardStartCol + BoardWidth + 2
' スコア表示セル（例："A1"）
Const ScoreDisplayCell As String = "A1"
'=== グローバル変数 ===
Dim Board(1 To BoardHeight, 1 To BoardWidth) As Integer ' 固定ブロック（0:空、それ以外はテトリミノ番号）
Dim Tetrominoes(1 To 7) As CTetromino ' 7種のテトリミノ
Dim PieceColors(1 To 7) As Long ' 各テトリミノの色
Dim currentPiece As CTetromino ' 現在操作中のテトリミノ
Dim currentPieceType As Integer ' 現在のテトリミノ番号
Dim currentX As Integer, currentY As Integer ' 現在のピボット位置（盤面セル番号）
Dim currentRotation As Integer ' 現在の回転状態（0～3）
Dim currentColor As Long ' 現在のテトリミノの色
Dim nextPiece As CTetromino ' 次に出現するテトリミノ
Dim nextPieceType As Integer ' 次テトリミノ番号
Dim Score As Long ' 得点
Dim GameInterval As Double ' 更新間隔（秒）※ここでは固定値として使用
Dim NextTick As Date ' 次回OnTime実行時刻
Dim GameRunning As Boolean ' ゲーム実行中フラグ
'=== 枠線を描画する（盤面範囲のみ） ===
Sub SetupBoardBorders()
Dim ws As Worksheet, r As Integer, c As Integer, cell As Range
Set ws = ThisWorkbook.Sheets("Tetris")
For r = BoardStartRow To BoardStartRow + BoardHeight - 1
For c = BoardStartCol To BoardStartCol + BoardWidth - 1
Set cell = ws.Cells(r, c)
With cell.Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
Next c
Next r
End Sub
'=== テトリミノ形状の初期化（前回と同じ）===
Sub InitTetrominoes()
Dim arr() As Integer
' I型
ReDim arr(0 To 3, 0 To 1)
arr(0, 0) = -1: arr(0, 1) = 0
arr(1, 0) = 0: arr(1, 1) = 0
arr(2, 0) = 1: arr(2, 1) = 0
arr(3, 0) = 2: arr(3, 1) = 0
Set Tetrominoes(1) = New CTetromino
Tetrominoes(1).Init arr
' O型
ReDim arr(0 To 3, 0 To 1)
arr(0, 0) = 0: arr(0, 1) = 0
arr(1, 0) = 1: arr(1, 1) = 0
arr(2, 0) = 0: arr(2, 1) = 1
arr(3, 0) = 1: arr(3, 1) = 1
Set Tetrominoes(2) = New CTetromino
Tetrominoes(2).Init arr
' T型
ReDim arr(0 To 3, 0 To 1)
arr(0, 0) = -1: arr(0, 1) = 0
arr(1, 0) = 0: arr(1, 1) = 0
arr(2, 0) = 1: arr(2, 1) = 0
arr(3, 0) = 0: arr(3, 1) = 1
Set Tetrominoes(3) = New CTetromino
Tetrominoes(3).Init arr
' L型
ReDim arr(0 To 3, 0 To 1)
arr(0, 0) = -1: arr(0, 1) = 0
arr(1, 0) = 0: arr(1, 1) = 0
arr(2, 0) = 1: arr(2, 1) = 0
arr(3, 0) = 1: arr(3, 1) = 1
Set Tetrominoes(4) = New CTetromino
Tetrominoes(4).Init arr
' J型
ReDim arr(0 To 3, 0 To 1)
arr(0, 0) = -1: arr(0, 1) = 0
arr(1, 0) = 0: arr(1, 1) = 0
arr(2, 0) = 1: arr(2, 1) = 0
arr(3, 0) = -1: arr(3, 1) = 1
Set Tetrominoes(5) = New CTetromino
Tetrominoes(5).Init arr
' S型
ReDim arr(0 To 3, 0 To 1)
arr(0, 0) = 0: arr(0, 1) = 0
arr(1, 0) = 1: arr(1, 1) = 0
arr(2, 0) = -1: arr(2, 1) = 1
arr(3, 0) = 0: arr(3, 1) = 1
Set Tetrominoes(6) = New CTetromino
Tetrominoes(6).Init arr
' Z型
ReDim arr(0 To 3, 0 To 1)
arr(0, 0) = -1: arr(0, 1) = 0
arr(1, 0) = 0: arr(1, 1) = 0
arr(2, 0) = 0: arr(2, 1) = 1
arr(3, 0) = 1: arr(3, 1) = 1
Set Tetrominoes(7) = New CTetromino
Tetrominoes(7).Init arr
End Sub
'=== ゲーム開始 ===
Sub StartGame()
Dim i As Integer, j As Integer
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Tetris")
' ★ 一度シート全体をクリア
ws.Cells.Clear
' ★ パフォーマンス向上のため、一時的に更新停止
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
' 盤面初期化
For i = 1 To BoardHeight
For j = 1 To BoardWidth
Board(i, j) = 0
Next j
Next i
' 盤面の枠線を描画（シートクリア後に行う）
SetupBoardBorders
' テトリミノ形状の初期化
InitTetrominoes
' テトリミノの色設定
PieceColors(1) = vbCyan
PieceColors(2) = vbYellow
PieceColors(3) = RGB(128, 0, 128)
PieceColors(4) = RGB(255, 165, 0)
PieceColors(5) = vbBlue
PieceColors(6) = vbGreen
PieceColors(7) = vbRed
' スコア初期化
Score = 0
DrawScore
' 次テトリミノの準備
nextPieceType = Int(7 * Rnd) + 1
Set nextPiece = Tetrominoes(nextPieceType)
DrawNextPiece
' ★ 更新間隔は固定（ここでは1秒）
GameInterval = 1
GameRunning = True
' キー割り当て
Application.OnKey "{LEFT}", "MoveLeft"
Application.OnKey "{RIGHT}", "MoveRight"
Application.OnKey "{UP}", "RotatePiece"
Application.OnKey "{DOWN}", "DropPiece"
' 盤面再描画
DrawBoard
SpawnPiece ' currentPieceにnextPieceを渡し、次のテトリミノも準備
NextTick = Now + GameInterval / 86400
Application.OnTime NextTick, "GameTick"
' ゲーム開始直後は更新再開
Application.ScreenUpdating = True
End Sub
Sub GameTick()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Tetris")
' 前回のスケジュールが残っている場合はキャンセル
On Error Resume Next
Application.OnTime EarliestTime:=NextTick, Procedure:="GameTick", Schedule:=False
On Error GoTo 0
If Not GameRunning Then Exit Sub
If currentPiece Is Nothing Then SpawnPiece
' １セルずつ下に移動（落下距離は固定）
If IsValidPosition(currentX, currentY + 1, currentRotation) Then
currentY = currentY + 1
Else
PlacePiece
ClearLines
SpawnPiece
If Not IsValidPosition(currentX, currentY, currentRotation) Then
GameOver
Exit Sub
End If
End If
DrawBoard
DoEvents
' 次回の更新時刻を設定（GameInterval は固定値）
NextTick = Now + GameInterval / 86400
Application.OnTime EarliestTime:=NextTick, Procedure:="GameTick", Schedule:=True
End Sub
'=== 新規テトリミノ生成 ===
Sub SpawnPiece()
' 事前に準備しておいた nextPiece を currentPiece に
Set currentPiece = nextPiece
currentPieceType = nextPieceType
currentRotation = 0
currentColor = PieceColors(currentPieceType)
currentX = Int(BoardWidth / 2) + 1
currentY = 1
' 次テトリミノの準備
nextPieceType = Int(7 * Rnd) + 1
Set nextPiece = Tetrominoes(nextPieceType)
DrawNextPiece
End Sub
'=== 配置可能判定 ===
Function IsValidPosition(posX As Integer, posY As Integer, rot As Integer) As Boolean
Dim blocks As Variant, i As Integer, col As Integer, row As Integer
If currentPiece Is Nothing Then
IsValidPosition = False
Exit Function
End If
blocks = currentPiece.GetBlocks(rot, posX, posY)
For i = 0 To 3
col = blocks(i)(0)
row = blocks(i)(1)
If col < 1 Or col > BoardWidth Or row < 1 Or row > BoardHeight Then
IsValidPosition = False
Exit Function
End If
If Board(row, col) <> 0 Then
IsValidPosition = False
Exit Function
End If
Next i
IsValidPosition = True
End Function
'=== テトリミノ固定 ===
Sub PlacePiece()
Dim blocks As Variant, i As Integer, col As Integer, row As Integer
If currentPiece Is Nothing Then Exit Sub
blocks = currentPiece.GetBlocks(currentRotation, currentX, currentY)
For i = 0 To 3
col = blocks(i)(0)
row = blocks(i)(1)
If row >= 1 And row <= BoardHeight And col >= 1 And col <= BoardWidth Then
Board(row, col) = currentPieceType
End If
Next i
End Sub
'=== ラインクリア ===
Sub ClearLines()
Dim r As Integer, c As Integer, fullLine As Boolean
Dim linesCleared As Integer: linesCleared = 0
For r = BoardHeight To 1 Step -1
fullLine = True
For c = 1 To BoardWidth
If Board(r, c) = 0 Then
fullLine = False
Exit For
End If
Next c
If fullLine Then
Dim rr As Integer, cc As Integer
For rr = r To 2 Step -1
For cc = 1 To BoardWidth
Board(rr, cc) = Board(rr - 1, cc)
Next cc
Next rr
For cc = 1 To BoardWidth
Board(1, cc) = 0
Next cc
linesCleared = linesCleared + 1
r = r + 1
End If
Next r
If linesCleared > 0 Then
Score = Score + linesCleared * 100
DrawScore
End If
End Sub
'=== 盤面描画（枠線はSetupBoardBordersで既に設定済み）===
Sub DrawBoard()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Tetris")
Dim r As Integer, c As Integer, cell As Range
Dim i As Integer, col As Integer, row As Integer
Dim blocks As Variant
' 各セルの内部色を更新
For r = 1 To BoardHeight
For c = 1 To BoardWidth
Set cell = ws.Cells(BoardStartRow + r - 1, BoardStartCol + c - 1)
If Board(r, c) <> 0 Then
cell.Interior.Color = PieceColors(Board(r, c))
Else
cell.Interior.Color = RGB(240, 240, 240)
End If
Next c
Next r
' 落下中のテトリミノ描画
If currentPiece Is Nothing Then Exit Sub
blocks = currentPiece.GetBlocks(currentRotation, currentX, currentY)
For i = 0 To 3
col = blocks(i)(0)
row = blocks(i)(1)
If row >= 1 And row <= BoardHeight And col >= 1 And col <= BoardWidth Then
Set cell = ws.Cells(BoardStartRow + row - 1, BoardStartCol + col - 1)
cell.Interior.Color = currentColor
End If
Next i
End Sub
'=== スコア表示 ===
Sub DrawScore()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Tetris")
ws.Range(ScoreDisplayCell).Value = "Score: " & Score
End Sub
'=== 次テトリミノ表示 ===
Sub DrawNextPiece()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Tetris")
Dim r As Integer, c As Integer, i As Integer
Dim cell As Range, blocks As Variant
' 表示エリアの範囲を設定（例：6×6セルの領域）
Dim startRow As Integer, endRow As Integer, startCol As Integer, endCol As Integer
startRow = NextPieceStartRow
startCol = NextPieceStartCol
endRow = NextPieceStartRow + 5
endCol = NextPieceStartCol + 5
' ① 表示エリアを白色に塗りつぶしてクリア（枠内のテトリミノ以外は白色）
For r = startRow To endRow
For c = startCol To endCol
Set cell = ws.Cells(r, c)
cell.Clear
cell.Interior.Color = vbWhite
' 一度既存のセル枠線は消す
cell.Borders.LineStyle = xlNone
Next c
Next r
' ② 表示エリア全体に太い外枠を描画
Dim rng As Range
Set rng = ws.Range(ws.Cells(startRow, startCol), ws.Cells(endRow, endCol))
With rng.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With rng.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With rng.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With rng.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
' ③ 次テトリミノを回転なし（0回転）、基準位置 (3,3) を使って描画
If nextPiece Is Nothing Then Exit Sub
blocks = nextPiece.GetBlocks(0, 3, 3)
For i = 0 To 3
Dim posX As Integer, posY As Integer
posX = blocks(i)(0)
posY = blocks(i)(1)
Set cell = ws.Cells(startRow + posY, startCol + posX)
cell.Interior.Color = PieceColors(nextPieceType)
' 必要に応じて各ブロックに薄い枠線を描画（任意）
With cell.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Next i
End Sub
'=== ユーザー操作マクロ ===
Sub MoveLeft()
If currentPiece Is Nothing Then Exit Sub
If IsValidPosition(currentX - 1, currentY, currentRotation) Then
currentX = currentX - 1
DrawBoard
End If
End Sub
Sub MoveRight()
If currentPiece Is Nothing Then Exit Sub
If IsValidPosition(currentX + 1, currentY, currentRotation) Then
currentX = currentX + 1
DrawBoard
End If
End Sub
Sub RotatePiece()
Dim newRot As Integer
If currentPiece Is Nothing Then Exit Sub
newRot = (currentRotation + 1) Mod 4
If IsValidPosition(currentX, currentY, newRot) Then
currentRotation = newRot
DrawBoard
End If
End Sub
Sub DropPiece()
If currentPiece Is Nothing Then Exit Sub
Do While IsValidPosition(currentX, currentY + 1, currentRotation)
currentY = currentY + 1
Loop
DrawBoard
GameTick
End Sub
'=== ゲームオーバー処理 ===
Sub GameOver()
GameRunning = False
MsgBox "ゲームオーバー！" & vbCrLf & "最終スコア：" & Score
Application.OnKey "{LEFT}"
Application.OnKey "{RIGHT}"
Application.OnKey "{UP}"
Application.OnKey "{DOWN}"
' ★ ゲーム終了時に各設定を元に戻す
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub EndGame()
GameRunning = False
On Error Resume Next
Application.OnTime EarliestTime:=NextTick, Procedure:="GameTick", Schedule:=False
Application.OnKey "{LEFT}"
Application.OnKey "{RIGHT}"
Application.OnKey "{UP}"
Application.OnKey "{DOWN}"
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
3. 使い方
1. Excelファイルの準備
ファイル形式
このマクロを利用するには、Excelのマクロ有効ファイル（.xlsm）として保存する必要があります。VBAエディタの起動
Excelで対象のブックを開き、Alt + F11 キーを押してVBAエディタを開きます。
2. コードの貼り付け
クラスモジュールの追加
① 新しいクラスモジュールを追加し、名前を「CTetromino」に変更します。
② 提供されたクラスモジュールのコードを、CTetrominoモジュールに貼り付けます。標準モジュールの追加
① 新しい標準モジュールを追加します。
② 残りのコード（盤面の初期化、ゲームループ、ユーザー操作などのコード）を、標準モジュールに貼り付けます。
3. マクロの実行
ゲーム開始
VBAエディタまたはExcel上から StartGame マクロを実行すると、シート「Tetris」に盤面が描画され、テトリスゲームがスタートします。
※ シート名「Tetris」が存在することを確認してください。必要に応じてシート名や描画開始位置の定数を調整してください。操作方法
左矢印キー：テトリミノを左に移動
右矢印キー：テトリミノを右に移動
上矢印キー：テトリミノを90度回転
下矢印キー：テトリミノを一気に落下
4. まとめ
今回はExcel VBAのテトリスゲームについてご紹介しました。
Excel VBAでのゲーム作成に興味がある方は、ぜひこのコードを手本に、自分なりのアレンジを加えてみてください。
※本記事で紹介しているマクロやファイルの使用に伴い発生したいかなるトラブルや損害についても、当方では一切の責任を負いかねます。すべて自己責任のもとでご利用ください。
5. ファイルの配布（有償or宣伝で無償）
コードは、ExcelのVBAエディタに貼り付けるだけで動作するようになっておりますが、実際の動作ファイルが必要な方のために、有料または、宣伝していただくことで無料配布しております。なお、以下の点についてご理解いただいた上でご購入ください。
動作保証について
Excelという環境上での実装となっているため、動作が非常に重かったり、PCのスペックによっては正常に動作しない可能性があります。ゲームとしての完成度や快適さは保証できませんので、あくまでExcel VBAの教材的な扱いとしてご検討ください。返金・トラブル対応について
万が一不具合やトラブルが発生した場合でも、動作の保証は致しかねます。Noteの返金設定は有効にしております。返金処理に関しては、Noteの規約に全て従うという点を予めご了承ください。ワンコインまたは、宣伝をお願いします。
本ファイルは、宣伝いただければ無料になる機能も有効にしています。
ワンコインよりも宣伝していただけると嬉しいです。
ただし、動作面の制約があることを十分にご理解いただいた上で、ご支援いただけますと幸いです。
また、購入して頂いた方向けに、補足情報もやパラメータの変更方法も紹介しております。
ここから先は
1,112字
/
1ファイル
この記事が気に入ったらチップで応援してみませんか？