0
1

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

@eeyore0721

Excel VBAで作る、かんたん「引き算脳トレ」ゲーム

0
Last updated at Posted at 2026-09-16

##■ 概要

Excel VBAで作る「引き算脳トレ」というオリジナルゲームです(VBAコードはGPTデフォルトバージョンです。このままでも遊べますがタイマー機能など現在リファクタリング中）

※リファクタリング済バージョンでは、フィッシャーイェーツ法などの複雑な処理を排除してT・FのBoolean型配列を使うなど簡単でおもしろい手法を採用してランダム処理を実装しています。

ルール：
・盤面（8列×6行＝48マス）に T/S/L/O/I の5種類のブロックを固定個数（T=15, S=12, L=9, O=7, I=5）でランダムに配置
・ラウンドごとに、2〜5種類をランダムに選び、その種類のセルだけを1個ずつアニメーション的に消していく
・消去が終わったら「START」表示 → プレイヤーは各種類について「何個消えたか」を頭の中で数えて入力欄にEnter
・判定は「入力値−実際に消えた数」の差で採点（差0=100点、差+1=80点、差+2〜5=段階的減点、差+6以上や差がマイナス=0点）
・ラウンドが進むごとに対象種類数が増え、制限時間が短くなる

「初期個数を頭に入れる→盤面を目で追って数える→時間内に引き算して確定する」という、記憶・観察・暗算を組み合わせたミニゲームになっています。

●標準モジュール

Option Explicit



' ============================================================

'  設定

' ============================================================

Public Const WS_NAME As String = "Game"

Public Const VER2_MODE As Boolean = False



' 盤面(グリッド)範囲

Public Const G_COL_L As Long = 2

Public Const G_COL_R As Long = 9

Public Const G_ROW_T As Long = 3

Public Const G_ROW_B As Long = 14

Public Const G_FILL_ROWS As Long = 6



' 入力欄の位置

Public Const IN_COL_LABEL As Long = 14

Public Const IN_COL_VALUE As Long = 15

Public Const IN_ROW_TOP As Long = 8



' 表示セル

Public Const CELL_MSG As String = "B1"

Public Const CELL_ROUND As String = "L2"

Public Const CELL_SCORE As String = "L3"

Public Const CELL_LIFE As String = "L4"



' ブロック5種類

Public BlockType(0 To 4) As String

Public BlockColor(0 To 4) As Long

Public FixedCount(0 To 4) As Long   '各タイプの初期固定個数(合計48)



' ゲーム状態(内部変数)

Public gRound As Long

Public gScore As Long

Public gLives As Long

Public fullCount(0 To 4) As Long

Public goneCount(0 To 4) As Long

Public remainCount(0 To 4) As Long

Public isActive(0 To 4) As Boolean

Public inputVal(0 To 4) As Long

Public inputGot(0 To 4) As Boolean



Public gWaitingForInput As Boolean

Public gActiveTypeCount As Long

Public gFilledCount As Long



#If VBA7 Then

    Public Declare PtrSafe Sub SleepAPI Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)

#Else

    Public Declare Sub SleepAPI Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)

#End If



' ============================================================

'  初期化

' ============================================================

Sub InitTypes()

    BlockType(0) = "T": BlockColor(0) = RGB(160, 90, 200)

    BlockType(1) = "S": BlockColor(1) = RGB(90, 190, 90)

    BlockType(2) = "L": BlockColor(2) = RGB(230, 150, 60)

    BlockType(3) = "O": BlockColor(3) = RGB(230, 210, 60)

    BlockType(4) = "I": BlockColor(4) = RGB(80, 190, 210)



    FixedCount(0) = 15  'T

    FixedCount(1) = 12  'S

    FixedCount(2) = 9   'L

    FixedCount(3) = 7   'O

    FixedCount(4) = 5   'I

End Sub



' ============================================================

'  ゲーム開始(ボタンに割り当てる)

' ============================================================

Sub StartGame()

    Randomize

    Call InitTypes

    gRound = 1

    gScore = 0

    gLives = 3



    Dim ws As Worksheet: Set ws = Worksheets(WS_NAME)

    On Error Resume Next

    ws.Unprotect

    On Error GoTo 0



    ws.Range(CELL_SCORE).Value = gScore

    ws.Range(CELL_LIFE).Value = IIf(VER2_MODE, gLives, "-")



    Call SetupInputLabels

    Call StartRound

End Sub



Sub SetupInputLabels()

    Dim ws As Worksheet: Set ws = Worksheets(WS_NAME)

    Dim i As Long

    ws.Cells.Locked = True



    For i = 0 To 4

        With ws.Cells(IN_ROW_TOP + i, IN_COL_LABEL)

            .Value = BlockType(i) & " ="

            .Font.Bold = True

        End With

        With ws.Cells(IN_ROW_TOP + i, IN_COL_VALUE)

            .Value = ""

            .Interior.Color = RGB(230, 230, 230)

            .Locked = False

        End With

    Next i



    ws.Protect UserInterfaceOnly:=True

End Sub



' ============================================================

'  ラウンド開始

' ============================================================

Sub StartRound()

    Dim ws As Worksheet: Set ws = Worksheets(WS_NAME)

    Dim numTypes As Long, itemsPerType As Long, intervalMs As Long, timeLimitSec As Long

    Call GetRoundParams(gRound, numTypes, itemsPerType, intervalMs, timeLimitSec)



    Application.EnableEvents = False



    ws.Range(CELL_ROUND).Value = gRound

    ws.Range(CELL_MSG).Value = "ラウンド " & gRound & " ： よく見ていてください…"



    Dim i As Long

    For i = 0 To 4

        fullCount(i) = 0: goneCount(i) = 0: remainCount(i) = 0

        isActive(i) = False: inputVal(i) = 0: inputGot(i) = False

        ws.Cells(IN_ROW_TOP + i, IN_COL_VALUE).Value = ""

        ws.Cells(IN_ROW_TOP + i, IN_COL_VALUE).Interior.Color = RGB(230, 230, 230)

    Next i



    Call ChooseActiveTypes(numTypes)

    Call FillGrid



    For i = 0 To 4

        fullCount(i) = FixedCount(i)

    Next i



    DoEvents

    SleepAPI 800



    Call RunDisappearPhase(itemsPerType, intervalMs)

    Call ShowInputPhase(timeLimitSec)

End Sub



' 難易度テーブル

Sub GetRoundParams(ByVal r As Long, ByRef numTypes As Long, ByRef itemsPerType As Long, _

                    ByRef intervalMs As Long, ByRef timeLimitSec As Long)

    Select Case r

        Case 1: numTypes = 2: itemsPerType = 3: intervalMs = 500: timeLimitSec = 60

        Case 2: numTypes = 3: itemsPerType = 3: intervalMs = 450: timeLimitSec = 50

        Case 3: numTypes = 3: itemsPerType = 4: intervalMs = 400: timeLimitSec = 40

        Case 4: numTypes = 4: itemsPerType = 4: intervalMs = 350: timeLimitSec = 30

        Case 5: numTypes = 4: itemsPerType = 5: intervalMs = 300: timeLimitSec = 25

        Case Else

            numTypes = 5: itemsPerType = 5: intervalMs = 250

            timeLimitSec = 20 - (r - 6)

            If timeLimitSec < 8 Then timeLimitSec = 8

    End Select

End Sub



Sub ChooseActiveTypes(ByVal n As Long)

    Dim pool(0 To 4) As Long, idx As Long, k As Long, r As Long, tmp As Long

    For idx = 0 To 4: pool(idx) = idx: Next idx

    For idx = 4 To 1 Step -1

        r = Int(Rnd() * (idx + 1))

        tmp = pool(idx): pool(idx) = pool(r): pool(r) = tmp

    Next idx

    For k = 0 To n - 1

        isActive(pool(k)) = True

    Next k

End Sub



' 盤面を固定個数リストのシャッフルで埋める

Sub FillGrid()

    Dim ws As Worksheet: Set ws = Worksheets(WS_NAME)

    Dim total As Long, i As Long, k As Long, n As Long



    total = 0

    For i = 0 To 4: total = total + FixedCount(i): Next i



    Dim bag() As Long

    ReDim bag(0 To total - 1)

    n = 0

    For i = 0 To 4

        For k = 1 To FixedCount(i)

            bag(n) = i: n = n + 1

        Next k

    Next i



    Dim r As Long, tmp As Long

    For i = total - 1 To 1 Step -1

        r = Int(Rnd() * (i + 1))

        tmp = bag(i): bag(i) = bag(r): bag(r) = tmp

    Next i



    ws.Range(ws.Cells(G_ROW_T, G_COL_L), ws.Cells(G_ROW_B - G_FILL_ROWS, G_COL_R)).ClearContents

    ws.Range(ws.Cells(G_ROW_T, G_COL_L), ws.Cells(G_ROW_B - G_FILL_ROWS, G_COL_R)).Interior.ColorIndex = xlNone

    ws.Range(ws.Cells(G_ROW_B - G_FILL_ROWS + 1, G_COL_L), ws.Cells(G_ROW_B, G_COL_R)).ClearContents

    ws.Range(ws.Cells(G_ROW_B - G_FILL_ROWS + 1, G_COL_L), ws.Cells(G_ROW_B, G_COL_R)).Interior.ColorIndex = xlNone



    Dim r2 As Long, c As Long, idx As Long

    idx = 0

    For r2 = G_ROW_B - G_FILL_ROWS + 1 To G_ROW_B

        For c = G_COL_L To G_COL_R

            If idx < total Then

                With ws.Cells(r2, c)

                    .Value = BlockType(bag(idx))

                    .Interior.Color = BlockColor(bag(idx))

                    .Font.Color = RGB(255, 255, 255)

                    .Font.Bold = True

                    .HorizontalAlignment = xlCenter

                End With

                idx = idx + 1

            End If

        Next c

    Next r2

End Sub



' ============================================================

'  消去フェーズ

' ============================================================

Sub RunDisappearPhase(ByVal itemsPerType As Long, ByVal intervalMs As Long)

    Dim ws As Worksheet: Set ws = Worksheets(WS_NAME)

    Dim goalCount(0 To 4) As Long, i As Long

    Dim totalTarget As Long, totalDone As Long



    For i = 0 To 4

        If isActive(i) Then

            goalCount(i) = itemsPerType + Int(Rnd() * 3) - 1

            If goalCount(i) < 1 Then goalCount(i) = 1

            If goalCount(i) > fullCount(i) Then goalCount(i) = fullCount(i)

            totalTarget = totalTarget + goalCount(i)

        End If

    Next i



    Do While totalDone < totalTarget

        Dim cand(0 To 4) As Long, cnt As Long

        cnt = 0

        For i = 0 To 4

            If isActive(i) And goneCount(i) < goalCount(i) Then

                cand(cnt) = i: cnt = cnt + 1

            End If

        Next i

        If cnt = 0 Then Exit Do



        Dim pick As Long

        pick = cand(Int(Rnd() * cnt))



        Dim found As Boolean, r As Long, c As Long, tries As Long

        found = False: tries = 0

        Do While Not found And tries < 500

            r = G_ROW_T + Int(Rnd() * (G_ROW_B - G_ROW_T + 1))

            c = G_COL_L + Int(Rnd() * (G_COL_R - G_COL_L + 1))

            If ws.Cells(r, c).Value = BlockType(pick) Then

                ws.Cells(r, c).ClearContents

                ws.Cells(r, c).Interior.ColorIndex = xlNone

                found = True

            End If

            tries = tries + 1

        Loop



        If found Then

            goneCount(pick) = goneCount(pick) + 1

            totalDone = totalDone + 1

            DoEvents

            SleepAPI intervalMs

        Else

            goalCount(pick) = goneCount(pick)

        End If

    Loop



    For i = 0 To 4

        remainCount(i) = fullCount(i) - goneCount(i)

    Next i

End Sub



' ============================================================

'  入力フェーズ

' ============================================================

Sub ShowInputPhase(ByVal timeLimitSec As Long)

    Dim ws As Worksheet: Set ws = Worksheets(WS_NAME)

    Dim i As Long



    ws.Range(CELL_MSG).Value = "START！ 消えた数を入力してEnter（制限時間 " & timeLimitSec & "秒）"



    gActiveTypeCount = 0

    gFilledCount = 0

    For i = 0 To 4

        inputGot(i) = False

        If isActive(i) Then

            gActiveTypeCount = gActiveTypeCount + 1

            ws.Cells(IN_ROW_TOP + i, IN_COL_VALUE).Interior.Color = RGB(255, 255, 200)

        End If

    Next i



    Application.EnableEvents = True

    gWaitingForInput = True

    ws.Cells(IN_ROW_TOP, IN_COL_VALUE).Select



    Application.OnTime Now + TimeSerial(0, 0, timeLimitSec), "TimeUp"

End Sub



Sub TimeUp()

    If gWaitingForInput Then Call FinishInputPhase

End Sub



Sub FinishInputPhase()

    gWaitingForInput = False

    Call JudgeRound

End Sub



' ============================================================

'  判定

' ============================================================

Sub JudgeRound()

    Dim ws As Worksheet: Set ws = Worksheets(WS_NAME)

    Dim i As Long, diff As Long, pts As Long, roundScore As Long

    Dim msg As String

    msg = "【ラウンド" & gRound & " 結果】" & vbCrLf



    For i = 0 To 4

        If isActive(i) Then

            If Not inputGot(i) Then inputVal(i) = 0

            diff = inputVal(i) - goneCount(i)



            Select Case True

                Case diff < 0

                    pts = 0

                    If VER2_MODE Then gLives = gLives - 1

                Case diff = 0

                    pts = 100

                Case diff = 1

                    pts = 80

                Case diff >= 2 And diff <= 5

                    pts = 50 - (diff - 2) * 10

                Case Else

                    pts = 0

            End Select



            roundScore = roundScore + pts

            msg = msg & BlockType(i) & "：消えた数=" & goneCount(i) & _

                  " 入力=" & inputVal(i) & " 差=" & diff & " → " & pts & "点" & vbCrLf

        End If

    Next i



    gScore = gScore + roundScore

    ws.Range(CELL_SCORE).Value = gScore

    ws.Range(CELL_LIFE).Value = IIf(VER2_MODE, gLives, "-")

    ws.Range(CELL_MSG).Value = "ラウンド" & gRound & " 獲得 " & roundScore & "点！（合計 " & gScore & "点）"



    Application.EnableEvents = False

    For i = 0 To 4

        ws.Cells(IN_ROW_TOP + i, IN_COL_VALUE).Interior.Color = RGB(230, 230, 230)

    Next i

    Application.EnableEvents = True



    MsgBox msg, vbInformation, "ラウンド結果"



    If VER2_MODE And gLives <= 0 Then

        Call GameOver

        Exit Sub

    End If



    gRound = gRound + 1

    Dim ans As VbMsgBoxResult

    ans = MsgBox("次のラウンドに進みますか？", vbYesNo + vbQuestion, "次へ")

    If ans = vbYes Then

        Call StartRound

    Else

        ws.Range(CELL_MSG).Value = "ゲーム終了。最終スコア：" & gScore

    End If

End Sub



Sub GameOver()

    Dim ws As Worksheet: Set ws = Worksheets(WS_NAME)

    ws.Range(CELL_MSG).Value = "ゲームオーバー！最終スコア：" & gScore

    MsgBox "ゲームオーバー！" & vbCrLf & "最終スコア：" & gScore, vbExclamation, "GAME OVER"

End Sub

●シートモジュール

Option Explicit



Private Sub Worksheet_Change(ByVal Target As Range)

    If Not gWaitingForInput Then Exit Sub

    If Target.Cells.Count > 1 Then Exit Sub

    If Target.Column <> IN_COL_VALUE Then Exit Sub



    Dim i As Long

    i = Target.Row - IN_ROW_TOP

    If i < 0 Or i > 4 Then Exit Sub

    If Not isActive(i) Then Exit Sub

    If inputGot(i) Then Exit Sub



    If IsNumeric(Target.Value) And Target.Value <> "" Then

        inputVal(i) = CLng(Target.Value)

        inputGot(i) = True

        gFilledCount = gFilledCount + 1

        Target.Interior.Color = RGB(200, 230, 200)



        If gFilledCount >= gActiveTypeCount Then

            Call FinishInputPhase

        End If

    End If

End Sub
0
1
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
0
1

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?